Merge branch 'master' into 466-zeit-wird-beim-editieren-zuruckgesetzt

CHANGELOG.md

@@ -2,6 +2,49 @@
 
 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.
 
+## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25)
+
+
+### Bug Fixes
+
+* fix startup on unix-socket ([39f1295](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/39f1295))
+* improve async behaviour ([cc7a528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cc7a528))
+* make migration idempotent again ([9778404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9778404))
+* restore behaviour of waiting asynchronously for job-management ([5ebcd89](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5ebcd89))
+* **communication:** make communication form more intuitive ([7a2b972](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a2b972)), closes [#387](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/387)
+* fix migration ([d2478a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2478a3))
+* fix migration & tests ([e05ea8e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e05ea8e))
+* migration ([4383eb1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4383eb1))
+* syntax ([7afd569](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7afd569))
+* **migration:** drop more tables in w.a. for inconsistent 21→22 ([d79dca6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d79dca6))
+* typo ([fb1e42d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb1e42d))
+
+
+### chore
+
+* bump versions ([67e3b38](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67e3b38))
+
+
+### Features
+
+* **course:** additional crosslinking ([5eaba78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5eaba78))
+* **exam-users:** document part-* family of columns ([fe07a22](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fe07a22))
+* **exams:** accept/reset computed results ([72342f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72342f1))
+* **exams:** automatically compute examResults ([ea5a398](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ea5a398))
+* **exams:** better display exam-result-information ([0ebda4d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0ebda4d))
+* **exams:** csv-import of ExamPartResults ([29f4e28](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/29f4e28))
+* **exams:** implement rounding of exambonus ([e97cd56](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e97cd56))
+* **exams:** refine exam form ([014a17a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/014a17a))
+
+
+### BREAKING CHANGES
+
+* yesod >=1.6
+* **exams:** examPartName no longer required
+* **exams:** Introduces ExamPartNumbers
+
+
+
 ### [6.11.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.0...v6.11.1) (2019-09-17)
 
 

README.md

@@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr
 ## Prerequisites
 These are the things you need to do/install before you can get started working on Uni2work.
 
+### Install german locale
+You will need to install the german locale at compile time.
+
+Install:
+
+- Edit `/etc/locale.gen` as root and uncomment/add the line `de_DE.UTF-8 UTF-8`
+- Save the file and run `sudo locale-gen`
+
 ### Clone repository
 Clone this repository and navigate into it
 ```sh
@@ -41,7 +49,7 @@ You'll get a prompt:
 
 ```sh
 Enter name of role to add: uniworx
-Shall the new role be a superuser? (y/n)  [not exactly sure. Guess not?]
+Shall the new role be a superuser? (y/n) y  [user must be superuser to create extensions]
 Password: uniworx
 ...
 ```
@@ -89,18 +97,6 @@ $ sudo apt-get install pkg-config
 $ sudo apt-get install libsodium-dev
 ```
 
-Build the app:
-```sh
-$ stack build
-```
-
-This might take a few minutes... if not hours... be prepared.
-
-install yesod:
-```sh
-$ stack install yesod-bin --install-ghc
-```
-
 ### `Node` & `npm`
 Node and Npm are needed to compile the frontend.
 
@@ -110,6 +106,18 @@ $ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash -
 $ sudo apt-get install -y nodejs
 ```
 
+Build the app:
+```sh
+$ npm run build
+```
+
+This might take a few minutes... if not hours... be prepared.
+
+install yesod:
+```sh
+$ stack install yesod-bin --install-ghc
+```
+
 ### Add dummy data to the database
 After building the app you can prepare the database and add some dummy data:
 ```sh
@@ -118,7 +126,7 @@ $ ./db.sh -f
 
 ## Run Uni2work
 ```sh
-$ npm start
+$ npm run start
 ```
 
 This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary.

app/DevelMain.hs

@@ -67,7 +67,7 @@ update = do
     restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
         killThread tid
         withStore doneStore takeMVar
-        readStore doneStore >>= start
+        withStore doneStore start
 
 
     -- | Start the server in a separate thread.
@@ -77,10 +77,7 @@ update = do
       (port, site, app) <- getApplicationRepl
       resourceForkIO $ do
         finally (liftIO $ runSettings (setPort port defaultSettings) app)
-          -- Note that this implies concurrency
+          (liftIO $ shutdownApp site `finally` putMVar done ())
-          -- between shutdownApp and the next app that is starting.
-          -- Normally this should be fine
-          (liftIO $ putMVar done () >> shutdownApp site)
 
 -- | kill the server
 shutdown :: IO ()

clean.sh

@@ -10,6 +10,8 @@ case $1 in
         ;;
     *)
         target=".stack-work-${1}"
+        shift
+
         if [[ ! -d "${target}" ]]; then
             printf "%s does not exist or is no directory\n" "${target}" >&2
             exit 1
@@ -20,7 +22,11 @@ case $1 in
         fi
 
         move-back() {
-            mv -v .stack-work "${target}"
+            if [[ -d .stack-work ]]; then
+                mv -v .stack-work "${target}"
+            else
+                mkdir -v "${target}"
+            fi
             [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work
         }
 
@@ -28,6 +34,9 @@ case $1 in
         mv -v "${target}" .stack-work
         trap move-back EXIT
 
-        stack clean
+        (
+            set -ex
+            stack clean $@
+        )
         ;;
 esac

config/test-settings.yml

@@ -8,3 +8,5 @@ log-settings:
   destination:   "test.log"
 
 auth-dummy-login: true
+
+job-workers: 1

frontend/src/utils/inputs/inputs.scss

@@ -33,11 +33,14 @@
   margin: 7px 0;
 }
 
-.form-section-title__hint {
+.form-group__hint, .form-section-title__hint {
-  margin-top: 7px;
   color: var(--color-fontsec);
   font-size: 0.9rem;
   font-weight: 600;
+}
+
+.form-section-title__hint {
+  margin-top: 7px;
 
   + .form-group {
     margin-top: 11px;
@@ -58,6 +61,7 @@
 .form-group--required .form-group-label__caption::after, .form-group__required-marker::before {
   content: ' *';
   color: var(--color-error);
+  font-weight: 600;
 }
 
 .form-group--optional {

haddock.sh

@@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then
     trap move-back EXIT
 fi
 
-stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
+stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal ${@}

messages/uniworx/de.msg

@@ -1135,8 +1135,10 @@ NavigationFavourites: Favoriten
 
 CommSubject: Betreff
 CommBody: Nachricht
+CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit <br> eingefügt werden.
 CommRecipients: Empfänger
 CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
+CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
 CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
 CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
 
@@ -1329,28 +1331,40 @@ ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Z
 ExamShowGrades: Klausur ist benotet
 ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde?
 ExamPublicStatistics: Statistik veröffentlichen
-ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können?
+ExamPublicStatisticsTip: Soll die automatisch berechnete statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können?
+ExamAutomaticGrading: Automatische Notenberechnung
+ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer automatisch aus den in den einzelnen Teilprüfungen erreichten Leistungen berechnet werden? Etwaige Bonuspunkte werden dabei berücksichtigt. Manuelles Überschreiben der Gesamtleistung ist dennoch möglich.
 ExamGradingRule: Notenberechnung
 ExamGradingManual': Keine automatische Berechnung
 ExamGradingKey': Nach Schlüssel
 ExamGradingKey: Notenschlüssel
-ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden
+ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilprüfungen mit ihrem Gewicht multipliziert wurden
 Points: Punkte
 PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein
 PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
 GradingFrom: Ab
 ExamNew: Neue Prüfung
+ExamBonus: Bonuspunkte-System
 ExamBonusRule: Prüfungsbonus aus Übungsbetrieb
 ExamNoBonus': Kein automatischer Bonus
 ExamBonusPoints': Umrechnung von Übungspunkten
+ExamBonusManual': Manuelle Berechnung
+
+ExamBonusAchieved: Bonuspunkte
 
 ExamEditHeading examn@ExamName: #{examn} bearbeiten
 
 ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte
+ExamBonusMaxPointsTip: Bonuspunkte werden, anhand der erreichten Übungspunkte bzw. der Anzahl von bestandenen Übungsblättern, linear zwischen null und der angegebenen Schranke interpoliert.
 ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein
 ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
+ExamBonusRound: Bonus runden auf
+ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein
+ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet.
 
-ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
+ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung
+ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
+ExamOccurrenceRule: Verfahren
 ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
 ExamRoomManual': Keine automatische Zuteilung
 ExamRoomSurname': Nach Nachname
@@ -1384,12 +1398,17 @@ ExamFormParts: Teile
 ExamCorrectors: Korrektoren
 ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
 
-ExamParts: Teilaufgaben
+ExamParts: Teilprüfungen/Aufgaben
-ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein
+ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
-ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits
+ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
-ExamPartName: Name
+ExamPartNumber: Nummer
+ExamPartNumbered examPartNumber@ExamPartNumber: Teil #{view _ExamPartNumber examPartNumber}
+ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet
+ExamPartName: Titel
+ExamPartNameTip: Wird den Studierenden angezeigt
 ExamPartMaxPoints: Maximalpunktzahl
 ExamPartWeight: Gewichtung
+ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an
 ExamPartResultPoints: Erreichte Punkte
 
 ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
@@ -1399,6 +1418,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet
 ExamNoShow: Nicht erschienen
 ExamVoided: Entwertet
 
+ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet
 ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte
 ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist
 
@@ -1437,8 +1457,13 @@ ExamSynchronised: Synchronisiert
 ExamUsersHeading: Prüfungsteilnehmer
 ExamUserDeregister: Teilnehmer von Prüfung abmelden
 ExamUserAssignOccurrence: Termin/Raum zuweisen
+ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen
+ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen
+ExamUserResetBonus: Auch Bonuspunkte zurücksetzen
 ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet
 ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt
+ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen
+ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt
 
 ExamUserSynchronised: Synchronisiert
 ExamUserSyncOfficeName: Name
@@ -1487,6 +1512,8 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
 CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können
 CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
 CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
+CsvColumnExamUserBonus: Anzurechnende Bonuspunkte
+CsvColumnExamUserParts: Erreichte Punktezahlen in den Teilprüfungen, sofern vorhanden; eine Spalte pro Teilprüfung
 CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
 CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
 
@@ -1518,8 +1545,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
 ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
 ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
 ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
+ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben
+ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
+ExamUserCsvSetBonus: Bonuspunkte eintragen
 ExamUserCsvSetResult: Ergebnis eintragen
+ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen
 ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
+ExamBonusNone: Keine Bonuspunkte
 
 ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
 

models/courses

@@ -17,11 +17,11 @@ Course    -- Information about a single course; contained info is always visible
     deregisterUntil  UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
     registerSecret   Text Maybe    -- enrolement maybe protected by a simple common passphrase
     materialFree     Bool          -- False: only enrolled users may see course materials not stored in this table
-    applicationsRequired       Bool
+    applicationsRequired       Bool default=false
     applicationsInstructions   Html Maybe
-    applicationsText           Bool
+    applicationsText           Bool default=false
-    applicationsFiles          UploadMode
+    applicationsFiles          UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb"
-    applicationsRatingsVisible Bool
+    applicationsRatingsVisible Bool default=false
     TermSchoolCourseShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolCourseName   term school name         -- name must be unique within school and semester
     deriving Generic

models/exams

@@ -1,9 +1,9 @@
 Exam
   course CourseId
   name ExamName
-  gradingRule ExamGradingRule
+  gradingRule ExamGradingRule Maybe
-  bonusRule ExamBonusRule
+  bonusRule ExamBonusRule Maybe
-  occurrenceRule ExamOccurrenceRule
+  occurrenceRule ExamOccurrenceRule Maybe
   visibleFrom UTCTime Maybe
   registerFrom UTCTime Maybe
   registerTo UTCTime Maybe
@@ -19,10 +19,12 @@ Exam
   UniqueExam course name
 ExamPart
   exam ExamId
-  name (CI Text)
+  number ExamPartNumber
+  name ExamPartName Maybe
   maxPoints Points Maybe
   weight Rational
-  UniqueExamPart exam name
+  UniqueExamPartNumber exam number
+  UniqueExamPartName exam name !force
 ExamOccurrence
   exam ExamId
   name ExamOccurrenceName
@@ -42,7 +44,14 @@ ExamPartResult
   examPart ExamPartId
   user UserId
   result ExamResultPoints
+  lastChanged UTCTime default=now()
   UniqueExamPartResult examPart user
+ExamBonus
+  exam ExamId
+  user UserId
+  bonus Points
+  lastChanged UTCTime default=now()
+  UniqueExamBonus exam user
 ExamResult
   exam ExamId
   user UserId

nixpkgs.nix

@@ -4,6 +4,6 @@
 import ((nixpkgs {}).fetchFromGitHub {
   owner = "NixOS";
   repo = "nixpkgs";
-  rev = "19.03";
+  rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf";
-  sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
+  sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm";
 })

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "6.11.1",
+  "version": "7.0.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
@@ -7702,9 +7702,9 @@
       "dev": true
     },
     "handlebars": {
-      "version": "4.1.2",
+      "version": "4.3.1",
-      "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz",
+      "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz",
-      "integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==",
+      "integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==",
       "dev": true,
       "requires": {
         "neo-async": "^2.6.0",
@@ -15623,9 +15623,9 @@
       "dev": true
     },
     "uglify-js": {
-      "version": "3.5.15",
+      "version": "3.6.0",
-      "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz",
+      "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz",
-      "integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==",
+      "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==",
       "dev": true,
       "optional": true,
       "requires": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "6.11.1",
+  "version": "7.0.0",
   "description": "",
   "keywords": [],
   "author": "",
@@ -14,7 +14,9 @@
     "yesod:start": "./start.sh",
     "yesod:lint": "./hlint.sh",
     "yesod:test": "./test.sh",
+    "yesod:test:watch": "./test.sh --file-watch",
     "yesod:build": "./build.sh",
+    "yesod:build:watch": "./build.sh --file-watch",
     "frontend:lint": "eslint frontend/src",
     "frontend:test": "karma start --conf karma.conf.js",
     "frontend:test:watch": "karma start --conf karma.conf.js --single-run false",

package.yaml

@@ -1,41 +1,39 @@
 name:    uniworx
-version: 6.11.1
+version: 7.0.0
 
 dependencies:
-  # Due to a bug in GHC 8.0.1, we block its usage
+  - base >=4.9.1.0 && <5
-  # See: https://ghc.haskell.org/trac/ghc/ticket/12130
+  - yesod >=1.6 && <1.7
-  - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+  - yesod-core >=1.6 && <1.7
-  # version 1.0 had a bug in reexporting Handler, causing trouble
+  - yesod-auth >=1.6 && <1.7
-  - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
+  - yesod-static >=1.6 && <1.7
-  - foreign-store
+  - yesod-form >=1.6 && <1.7
-  - yesod >=1.4.3 && <1.5
+  - classy-prelude >=1.5 && <1.6
-  - yesod-core >=1.4.30 && <1.5
+  - classy-prelude-conduit >=1.5 && <1.6
-  - yesod-auth >=1.4.0 && <1.5
+  - classy-prelude-yesod >=1.5 && <1.6
-  - yesod-static >=1.4.0.3 && <1.6
+  - bytestring >=0.10 && <0.11
-  - yesod-form >=1.4.0 && <1.5
-  - classy-prelude >=0.10.2
-  - classy-prelude-conduit >=0.10.2
-  - bytestring >=0.9 && <0.11
   - text >=0.11 && <2.0
-  - persistent >=2.7.2 && <2.8
+  - persistent >=2.9 && <2.10
-  - persistent-postgresql >=2.1.1 && <2.8
+  - persistent-postgresql >=2.9 && <2.10
-  - persistent-template >=2.0 && <2.8
+  - persistent-template >=2.5 && <2.9
+  - persistent-qq >=2.9 && <2.10
   - template-haskell
   - shakespeare >=2.0 && <2.1
   - hjsmin >=0.1 && <0.3
   - monad-control >=0.3 && <1.1
   - wai-extra >=3.0 && <3.1
-  - yaml >=0.8 && <0.9
+  - yaml >=0.11 && <0.12
-  - http-conduit >=2.1 && <2.3
+  - http-conduit >=2.3 && <2.4
   - directory >=1.1 && <1.4
   - warp >=3.0 && <3.3
   - data-default
-  - aeson >=0.6 && <1.3
+  - aeson >=1.4 && <1.5
   - conduit >=1.0 && <2.0
   - conduit-combinators
   - monad-logger >=0.3 && <0.4
   - fast-logger >=2.2 && <2.5
   - wai-logger >=2.2 && <2.4
+  - foreign-store
   - file-embed
   - safe
   - unordered-containers
@@ -52,11 +50,12 @@ dependencies:
   - http-api-data
   - profunctors
   - colonnade >=1.1.1
-  - yesod-colonnade >=1.1.0
   - blaze-markup
   - zip-stream
+  - encoding
   - filepath
   - transformers
+  - transformers-base
   - wl-pprint-text
   - uuid-types
   - path-pieces
@@ -100,8 +99,10 @@ dependencies:
   - th-abstraction
   - HaskellNet
   - HaskellNet-SSL
-  - network
+  - network >=3
-  - resource-pool
+  - network-bsd
+  - unliftio
+  - unliftio-pool
   - mime-mail
   - hashable
   - aeson-pretty
@@ -116,7 +117,6 @@ dependencies:
   - pkcs7
   - memcached-binary
   - directory-tree
-  - lifted-base
   - lattices
   - hsass
   - semigroupoids
@@ -126,7 +126,6 @@ dependencies:
   - mono-traversable
   - lens-aeson
   - systemd
-  - lifted-async
   - streaming-commons
   - hourglass
   - unix
@@ -138,6 +137,7 @@ dependencies:
   - pqueue
   - deepseq
   - multiset
+  - retry
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -183,6 +183,7 @@ default-extensions:
   - DeriveLift
   - DeriveFunctor
   - DerivingStrategies
+  - DerivingVia
   - DataKinds
   - BinaryLiterals
   - PolyKinds
@@ -190,9 +191,12 @@ default-extensions:
   - TypeApplications
   - RecursiveDo
   - TypeFamilyDependencies
+  - QuantifiedConstraints
 
 ghc-options:
   - -Wall
+  - -Wmissing-home-modules
+  - -Wredundant-constraints
   - -fno-warn-type-defaults
   - -fno-warn-unrecognised-pragmas
   - -fno-warn-partial-type-signatures

shell.nix

@@ -19,7 +19,7 @@ let
   '';
 
   override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
+  nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-12_x postgresql openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 
@@ -47,6 +47,12 @@ let
         set +xe
       fi
 
+      if [ -n "$ZSH_VERSION" ]; then
+        autoload -U +X compinit && compinit
+        autoload -U +X bashcompinit && bashcompinit
+      fi
+      eval "$(stack --bash-completion-script stack)"
+
       ${oldAttrs.shellHook}
     '';
   };

src/Application.hs

@@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                              defaultShouldDisplayException,
-                                             runSettingsSocket, setHost,
+                                             runSettings, runSettingsSocket, setHost,
                                              setBeforeMainLoop,
                                              setOnException, setPort, getPort)
 import Data.Streaming.Network               (bindPortTCP)
@@ -54,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS
 
 import Network.HaskellNet.SSL hiding (Settings)
 import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
-import Data.Pool
+
+import UnliftIO.Concurrent
+import UnliftIO.Pool
 
 import Control.Monad.Trans.Resource
 
@@ -70,17 +72,17 @@ import System.Exit
 import qualified Database.Memcached.Binary.IO as Memcached
 
 import qualified System.Systemd.Daemon as Systemd
-import Control.Concurrent.Async.Lifted.Safe
 import System.Environment (lookupEnv)
 import System.Posix.Process (getProcessID)
-import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
+import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
 import qualified System.Posix.Signals as Signals (Handler(..))
 
-import Network (socketPort)
+import Network.Socket (socketPort, Socket, PortNumber)
 import qualified Network.Socket as Socket (close)
 
 import Control.Concurrent.STM.Delay
 import Control.Monad.STM (retry)
+import Control.Monad.Trans.Cont (runContT, callCC)
 
 import qualified Data.Set as Set
 
@@ -120,7 +122,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
+makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
 makeFoundation appSettings'@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
@@ -146,7 +148,7 @@ makeFoundation appSettings'@AppSettings{..} = do
               oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
               rmLoggerSet $ loggerSet oldLogger
               updateLogger newSettings
-        (tVar, ) <$> fork (updateLogger initialSettings)
+        (tVar, ) <$> forkIO (updateLogger initialSettings)
     appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
 
     let appStatic = embeddedStatic
@@ -250,7 +252,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil
           instanceId <- UUID.nextRandom
           LBS.writeFile idFile $ UUID.toByteString instanceId
           return instanceId
-      | otherwise = throw e
+      | otherwise = throwIO e
 
 createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
 createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
@@ -327,7 +329,7 @@ warpSettings foundation = defaultSettings
                                   void $ liftIO Systemd.notifyReady
                             if
                               | foundation ^. _appHealthCheckDelayNotify
-                                -> void . fork $ do
+                                -> void . forkIO $ do
                                   let activeChecks = Set.fromList universeF
                                                    & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
                                   atomically $ do
@@ -365,11 +367,20 @@ develMain = runResourceT $ do
   wsettings <- liftIO . getDevSettings $ warpSettings foundation
   app <- makeApplication foundation
 
+  let
+    awaitTermination :: IO ()
+    awaitTermination
+      = flip runContT return . forever $ do
+          lift $ threadDelay 100e3
+          whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $
+            callCC ($ ())
+  
+  void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing
   runAppLoggingT foundation $ handleJobs foundation
-  liftIO . develMainHelper $ return (wsettings, app)
+  void . liftIO $ awaitTermination `race` runSettings wsettings app
 
 -- | The @main@ function for an executable running this site.
-appMain :: MonadResourceBase m => m ()
+appMain :: forall m. MonadUnliftIO m => m ()
 appMain = runResourceT $ do
     settings <- getAppSettings
 
@@ -397,7 +408,7 @@ appMain = runResourceT $ do
           $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
           liftIO $ pure <$> bindPortTCP port host
 
-      $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets
+      $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets
 
       mainThreadId <- myThreadId
       liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
@@ -445,7 +456,7 @@ appMain = runResourceT $ do
                            _other -> return ()
 
                          go status
-                in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
+                in void $ allocateLinkedAsync notifyWatchdog
         _other -> return ()
 
       let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
@@ -461,7 +472,7 @@ appMain = runResourceT $ do
 foundationStoreNum :: Word32
 foundationStoreNum = 2
 
-getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
+getApplicationRepl :: (MonadResource m, MonadUnliftIO m) => m (Int, UniWorX, Application)
 getApplicationRepl = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
@@ -475,7 +486,7 @@ getApplicationRepl = do
 
     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
+shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m ()
 shutdownApp app = do
   stopJobCtl app
   liftIO $ do
@@ -494,7 +505,7 @@ handler :: Handler a -> IO a
 handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
 
 -- | Run DB queries
-db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
+db :: DB a -> IO a
 db = handler . runDB
 
 addPWEntry :: User

src/Audit.hs

@@ -22,7 +22,7 @@ import qualified Network.Socket as Wai
 import qualified Net.IP as IP
 import qualified Net.IPv6 as IPv6
 
-import Control.Exception (ErrorCall(..), evaluate)
+import Control.Exception (ErrorCall(..))
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
@@ -79,7 +79,6 @@ instance Exception AuditException
 
 
 audit :: ( AuthId (HandlerSite m) ~ Key User
-         , AuthEntity (HandlerSite m) ~ User
          , IsSqlBackend (YesodPersistBackend (HandlerSite m))
          , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
          , HasInstanceID (HandlerSite m) InstanceId
@@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do
 
   transactionLogTime <- liftIO getCurrentTime
   transactionLogInstance <- getsYesod $ view instanceID
-  transactionLogInitiator <- liftHandlerT maybeAuthId
+  transactionLogInitiator <- liftHandler maybeAuthId
   transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
 
   insert_ TransactionLog{..}

src/Audit/Types.hs

@@ -23,6 +23,24 @@ data Transaction
     { transactionExam   :: ExamId
     , transactionUser   :: UserId
     }
+  
+  | TransactionExamPartResultEdit
+    { transactionExamPart :: ExamPartId
+    , transactionUser     :: UserId
+    }
+  | TransactionExamPartResultDeleted
+    { transactionExamPart :: ExamPartId
+    , transactionUser     :: UserId
+    }
+
+  | TransactionExamBonusEdit
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
+    }
+  | TransactionExamBonusDeleted
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
+    }
 
   | TransactionExamResultEdit
     { transactionExam   :: ExamId

src/Auth/Dummy.hs

@@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
-dummyForm :: ( RenderMessage site FormMessage
+dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
-             , RenderMessage site DummyMessage
+             , RenderMessage (HandlerSite m) DummyMessage
-             , YesodPersist site
+             , YesodPersist (HandlerSite m)
-             , SqlBackendCanRead (YesodPersistBackend site)
+             , SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
-             , Button site ButtonSubmit
+             , Button (HandlerSite m) ButtonSubmit
-             ) => AForm (HandlerT site IO) (CI Text)
+             , MonadHandler m
+             ) => AForm m (CI Text)
 dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
   where
-    userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
+    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
     toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
-dummyLogin :: ( YesodAuth site
+dummyLogin :: forall site.
+              ( YesodAuth site
               , YesodPersist site
               , SqlBackendCanRead (YesodPersistBackend site)
-              , RenderMessage site FormMessage
               , RenderMessage site AFormMessage
               , RenderMessage site DummyMessage
               , Button site ButtonSubmit
               ) => AuthPlugin site
 dummyLogin = AuthPlugin{..}
   where
+    apName :: Text
     apName = "dummy"
-    -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
+    
-    apDispatch "POST" [] = do
+    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
-      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
+    apDispatch "POST" [] = liftSubHandler $ do
+      ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
+      tp <- getRouteToParent
       case loginRes of
         FormFailure errs -> do
-          lift . forM_ errs $ addMessage Error . toHtml
+          forM_ errs $ addMessage Error . toHtml
-          redirect LoginR
+          redirect $ tp LoginR
         FormMissing -> do
-          lift $ addMessageI Warning MsgDummyNoFormData
+          addMessageI Warning MsgDummyNoFormData
-          redirect LoginR
+          redirect $ tp LoginR
         FormSuccess ident ->
-          lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
+          setCredsRedirect $ Creds "dummy" (CI.original ident) []
     apDispatch _ _ = notFound
+  
+    apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
       let loginForm = wrapForm login FormSettings

src/Auth/LDAP.hs

@@ -84,7 +84,7 @@ instance Exception CampusUserException
 
 makePrisms ''CampusUserException
 
-campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
+campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
 campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
   Ldap.bind ldap ldapDn ldapPassword
   results <- case lookup "DN" credsExtra of
@@ -109,15 +109,15 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
                   , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
                   ]
 
-campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
+campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
 campusUser' conf pool User{userIdent}
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
 
 
-campusForm :: ( RenderMessage site FormMessage
+campusForm :: ( RenderMessage (HandlerSite m) FormMessage
-              , RenderMessage site CampusMessage
+              , RenderMessage (HandlerSite m) CampusMessage
-              , Button site ButtonSubmit
+              , MonadHandler m
-              ) => WForm (HandlerT site IO) (FormResult CampusLogin)
+              ) => WForm m (FormResult CampusLogin)
 campusForm = do
   MsgRenderer mr <- getMsgRenderer
   
@@ -133,24 +133,26 @@ apLdap = "LDAP"
 
 campusLogin :: forall site.
                ( YesodAuth site
-               , RenderMessage site FormMessage
                , RenderMessage site CampusMessage
                , RenderMessage site AFormMessage
                , Button site ButtonSubmit
                ) => LdapConf -> LdapPool -> AuthPlugin site
 campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
+    apName :: Text
     apName = apLdap
-    apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
+  
-    apDispatch "POST" [] = do
+    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
-      ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm
+    apDispatch "POST" [] = liftSubHandler $ do
+      ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
+      tp <- getRouteToParent
       case loginRes of
         FormFailure errs -> do
           forM_ errs $ addMessage Error . toHtml
-          redirect LoginR
+          redirect $ tp LoginR
-        FormMissing -> redirect LoginR
+        FormMissing -> redirect $ tp LoginR
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
-          ldapResult <- withLdap pool $ \ldap -> do
+          ldapResult <- withLdap pool $ \ldap -> liftIO $ do
             Ldap.bind ldap ldapDn ldapPassword
             searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
             case searchResults of
@@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
                   $logErrorS "LDAP" $ "Error during login: " <> tshow err
                   loginErrorMessageI LoginR Msg.AuthError
             Right (Right (userDN, credsIdent)) ->
-              lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
+              setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
             Right (Left searchResults) -> do
               $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
               loginErrorMessageI LoginR Msg.AuthError
     apDispatch _ _ = notFound
+
+    apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
       let loginForm = wrapForm login FormSettings

src/Auth/PWHash.hs

@@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
-hashForm :: ( RenderMessage site FormMessage
+hashForm :: ( RenderMessage (HandlerSite m) FormMessage
-            , RenderMessage site PWHashMessage
+            , RenderMessage (HandlerSite m) PWHashMessage
-            , Button site ButtonSubmit
+            , MonadHandler m
-            ) => AForm (HandlerT site IO) HashLogin
+            ) => AForm m HashLogin
 hashForm = HashLogin
   <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
   <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
 
 
-hashLogin :: ( YesodAuth site
+hashLogin :: forall site.
+             ( YesodAuth site
              , YesodPersist site
              , SqlBackendCanRead (YesodPersistBackend site)
-             , RenderMessage site FormMessage
+             , PersistRecordBackend User (YesodPersistBackend site)
              , RenderMessage site PWHashMessage
              , RenderMessage site AFormMessage
              , Button site ButtonSubmit
              ) => PWHashAlgorithm -> AuthPlugin site
 hashLogin pwHashAlgo = AuthPlugin{..}
   where
+    apName :: Text
     apName = "PWHash"
-    apDispatch "POST" [] = do
+
-      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
+    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
+    apDispatch "POST" [] = liftSubHandler $ do
+      ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm
+      tp <- getRouteToParent
       case loginRes of
         FormFailure errs -> do
           forM_ errs $ addMessage Error . toHtml
-          redirect LoginR
+          redirect $ tp LoginR
-        FormMissing -> redirect LoginR
+        FormMissing -> redirect $ tp LoginR
         FormSuccess HashLogin{..} -> do
-          user <- lift . runDB . getBy $ UniqueAuthentication hashIdent
+          user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
           case user of
             Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
               | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
-                  lift . setCredsRedirect $ Creds apName userIdent []
+                  setCredsRedirect $ Creds apName userIdent []
             other -> do
               $logDebugS "PWHash" $ tshow other
               loginErrorMessageI LoginR Msg.InvalidLogin
-    -- apDispatch "GET" [] = do
-    --   authData <- lookupBasicAuth
-    --   pwdata <- liftIO $ Yaml.decodeFileEither fp
-
-    --   addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
-
-    --   case pwdata of
-    --     Left err -> $logDebugS "Auth" $ tshow err
-    --     Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
-
-    --   case (authData, pwdata) of
-    --     (Nothing, _) -> do
-    --       notAuthenticated
-    --     (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
-    --       | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
-    --           <- [ pwe | pwe@PWEntry{..} <- pwdata'
-    --                    , let User{..} = pwUser
-    --                    , userIdent  == usr
-    --                    , userPlugin == apName
-    --              ]
-    --       , verifyPassword pw pwHash
-    --         -> lift $ do
-    --           runDB . void $ insertUnique pwUser
-    --           setCredsRedirect $ Creds apName userIdent []
-    --     _ -> permissionDenied "Invalid auth"
     apDispatch _ _ = notFound
+
+    apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
       let loginForm = wrapForm login FormSettings

src/Control/Concurrent/Async/Lifted/Safe/Utils.hs

@@ -1,17 +0,0 @@
-module Control.Concurrent.Async.Lifted.Safe.Utils
-  ( allocateAsync, allocateLinkedAsync
-  ) where
-
-import ClassyPrelude hiding (cancel)
-import Control.Lens
-
-import Control.Concurrent.Async.Lifted.Safe
-
-import Control.Monad.Trans.Resource
-
-
-allocateLinkedAsync, allocateAsync :: forall m a.
-                                      MonadResource m
-                                   => IO a -> m (Async a)
-allocateAsync = fmap (view _2) . flip allocate cancel . async
-allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync

src/CryptoID.hs

@@ -8,11 +8,12 @@ module CryptoID
   , module System.FilePath.Cryptographic.ImplicitNamespace
   ) where
 
-import CryptoID.TH
 
-import ClassyPrelude
+import Import.NoModel
 import Model
 
+import CryptoID.TH
+
 import qualified Data.CryptoID as E
 import Data.CryptoID.Poly.ImplicitNamespace
 import Data.UUID.Cryptographic.ImplicitNamespace
@@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace
 
 import qualified Data.Text as Text
 
--- import Data.UUID.Types
-import Web.PathPieces
-
 import           Data.CaseInsensitive   (CI)
 import qualified Data.CaseInsensitive as CI
 

src/Data/CaseInsensitive/Instances.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Data.CaseInsensitive.Instances
   (

src/Data/CryptoID/Instances.hs

@@ -43,5 +43,5 @@ instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
 instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
   toField = Csv.toField . CID.ciphertext
 
-instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
+instance {-# OVERLAPS #-} Csv.ToField s => Csv.ToField (CID.CryptoID c (CI s)) where
   toField = Csv.toField . CI.foldedCase . CID.ciphertext

src/Data/List/NonEmpty/Instances.hs

@@ -1,12 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Data.List.NonEmpty.Instances
-  (
-  ) where
-
-import Data.List.NonEmpty
-
-import Language.Haskell.TH.Syntax (Lift(..))
-
-instance Lift a => Lift (NonEmpty a) where
-  lift (toList -> xs) = [e|fromList xs|]

src/Database/Esqueleto/Utils.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Database.Esqueleto.Utils
   ( true, false
@@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool)
 false = E.val False
 
 -- | Negation of `isNothing` which is missing
-isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
+isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
 isJust = E.not_ . E.isNothing
 
 infix 4 `isInfixOf`, `hasInfix`
 
 -- | Check if the first string is contained in the text derived from the second argument
-isInfixOf :: ( E.Esqueleto query expr backend
+isInfixOf :: ( E.SqlString s1
-             , E.SqlString s1
              , E.SqlString s2
              )
-          => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool)
+          => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
 isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
 
-hasInfix :: ( E.Esqueleto query expr backend
+hasInfix :: ( E.SqlString s1
-            , E.SqlString s1
             , E.SqlString s2
             )
-         => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
+         => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
 hasInfix = flip isInfixOf
 
 and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)

src/Database/Persist/Class/Instances.hs

@@ -8,11 +8,14 @@ module Database.Persist.Class.Instances
 import ClassyPrelude
 
 import Database.Persist.Class
+import Database.Persist.Types (HaskellName, DBName, PersistValue)
 import Database.Persist.Types.Instances ()
 
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
+import qualified Data.Map as Map
+
 
 instance PersistEntity record => Hashable (Key record) where
   hashWithSalt s = hashWithSalt s . toPersistValue
@@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where
 
 instance PersistEntity record => NFData (Key record) where
   rnf = rnf . keyToValues
+
+
+uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue
+uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues
+
+instance PersistEntity record => Eq (Unique record) where
+  (==) = (==) `on` uniqueToMap
+  
+instance PersistEntity record => Show (Unique record) where
+  showsPrec p = showsPrec p . uniqueToMap

src/Foundation.hs

@@ -5,7 +5,6 @@
 module Foundation where
 
 import Import.NoFoundation hiding (embedFile)
-import qualified ClassyPrelude.Yesod as Yesod (getHttpManager)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 
@@ -48,9 +47,6 @@ import Data.List (nubBy, (!!), findIndex)
 
 import Data.Monoid (Any(..))
 
-import Data.Pool
-
-import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
@@ -94,6 +90,8 @@ import Data.FileEmbed (embedFile)
 
 import qualified Ldap.Client as Ldap
 
+import UnliftIO.Pool
+
 
 type SMTPPool = Pool SMTPConnection
 
@@ -162,9 +160,9 @@ deriving instance Generic (Route UniWorX)
 
 -- | Convenient Type Synonyms:
 type DB = YesodDB UniWorX
-type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
+type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
-type MailM a = MailT (HandlerT UniWorX IO) a
+type MailM a = MailT (HandlerFor UniWorX) a
 
 -- Pattern Synonyms for convenience
 pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX
@@ -531,13 +529,13 @@ class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
   evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 
 instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
-  evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
+  evalAccessPred aPred aid r w = liftHandler $ case aPred of
     (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
     (APHandler p) -> p aid r w
     (APDB      p) -> runDB $ p aid r w
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
-  evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
+  evalAccessPred aPred aid r w = mapReaderT liftHandler $ 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
@@ -573,7 +571,6 @@ falseAP = APPure . const . const . const $ falseAR <$> ask -- included for compl
 askTokenUnsafe :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
-                  , MonadLogger m
                   , MonadCatch m
                   )
                => ExceptT AuthResult m (BearerToken (UniWorX))
@@ -690,7 +687,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
 tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute
-  allow <- view _appAllowDeprecated
+  allow <- getsYesod $ view _appAllowDeprecated
   return $ bool (Unauthorized "Deprecated Route") Authorized allow
 tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
@@ -1107,9 +1104,9 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
 tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
     cTime <- liftIO getCurrentTime
-    let authorizedIfExists f = do
+    let
-          [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
+      authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
-          whenExceptT ok Authorized
+      authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
     participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
     -- participant is currently registered
     $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
@@ -1395,42 +1392,42 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
 
       return result
 
-evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 evalAccessFor mAuthId route isWrite = do
   dnf <- either throwM return $ routeAuthTags route
   fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
 
-evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
+evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
 evalAccessForDB = evalAccessFor
 
-evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
+evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
 evalAccess route isWrite = do
-  mAuthId <- liftHandlerT maybeAuthId
+  mAuthId <- liftHandler maybeAuthId
   tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
   dnf <- either throwM return $ routeAuthTags route
   (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
   result <$ tellSessionJson SessionInactiveAuthTags deactivated
 
-evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
+evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
 evalAccessDB = evalAccess
 
 -- | Check whether the current user is authorized by `evalAccess` for the given route
 --   Convenience function for a commonly used code fragment
-hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool
+hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool
 hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
 
 -- | Check whether the current user is authorized by `evalAccess` to read from the given route
 --   Convenience function for a commonly used code fragment
-hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
+hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
 hasReadAccessTo = flip hasAccessTo False
 
 -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
 --   Convenience function for a commonly used code fragment
-hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
+hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
 hasWriteAccessTo = flip hasAccessTo True
 
 -- | Conditional redirect that hides the URL if the user is not authorized for the route
-redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
+redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
 redirectAccess url = do
   -- must hide URL if not authorized
   access <- evalAccess url False
@@ -1439,7 +1436,7 @@ redirectAccess url = do
     _          -> permissionDeniedI MsgUnauthorizedRedirect
 
 -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
-evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX)
+evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
             => TermId -> SchoolId -> CourseShorthand -> m AuthResult
 evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
 
@@ -1481,7 +1478,7 @@ instance Yesod UniWorX where
                 $logDebugS "updateFavourites" "Updating favourites"
 
                 now <- liftIO $ getCurrentTime
-                uid <- MaybeT $ liftHandlerT maybeAuthId
+                uid <- MaybeT $ liftHandler maybeAuthId
                 cid  <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
                 user <- MaybeT $ get uid
                 let courseFavourite = CourseFavourite uid now cid
@@ -1533,7 +1530,7 @@ instance Yesod UniWorX where
         encrypted :: ToJSON a => a -> Widget -> Widget
         encrypted plaintextJson plaintext = do
           canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-          shouldEncrypt <- view _appEncryptErrors
+          shouldEncrypt <- getsYesod $ view _appEncryptErrors
           if
             | shouldEncrypt
             , not canDecrypt -> do
@@ -1596,14 +1593,13 @@ instance Yesod UniWorX where
                  . decodeUtf8
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
-                 . runIdentity
+                 . runConduitPure
-                 $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
+                 $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash
 
     fileUpload _site _length = FileUploadMemory lbsBackEnd
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
-    shouldLog _ _ _ = error "Must use shouldLogIO"
     shouldLogIO app _source level = do
       LogSettings{..} <- readTVarIO $ appLogSettings app
       return $ logAll || level >= logMinimumLevel
@@ -1626,7 +1622,7 @@ siteLayout = siteLayout' . Just
 siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout' headingOverride widget = do
-  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
 
   isModal <- hasCustomHeader HeaderIsModal
 
@@ -1747,7 +1743,7 @@ siteLayout' headingOverride widget = do
 
 
 applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
-applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
+applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
   where
     applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
       cID <- encrypt smId
@@ -2548,7 +2544,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
           case muid of
             Nothing -> return False
             (Just uid) -> do
-              [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
+              ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
                 E.on $ submission E.^. SubmissionSheet E.==. sheet  E.^. SheetId
                 E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
                 E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
@@ -2717,6 +2713,24 @@ pageActions (CExamR tid ssh csh examn EUsersR) =
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamGrades
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CExamR tid ssh csh examn EGradesR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamUsers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem
@@ -2726,7 +2740,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
       , menuItemModal = True
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- MaybeT $ liftHandlerT maybeAuthId
+          uid <- MaybeT $ liftHandler maybeAuthId
           submissions <- lift $ submissionList tid csh shn uid
           guard $ null submissions
           return True
@@ -2738,7 +2752,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- MaybeT $ liftHandlerT maybeAuthId
+          uid <- MaybeT $ liftHandler maybeAuthId
           submissions <- lift $ submissionList tid csh shn uid
           guard . not $ null submissions
           return True
@@ -2948,7 +2962,7 @@ pageActions (CorrectionsR) =
       , menuItemRoute = SomeRoute CorrectionsCreateR
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- MaybeT $ liftHandlerT maybeAuthId
+          uid <- MaybeT $ liftHandler maybeAuthId
           sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
@@ -2987,7 +3001,7 @@ pageActions (CorrectionsGradeR) =
       , menuItemRoute = SomeRoute CorrectionsCreateR
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- MaybeT $ liftHandlerT maybeAuthId
+          uid <- MaybeT $ liftHandler maybeAuthId
           sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
@@ -3006,7 +3020,7 @@ pageActions _ = []
 
 
 i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m ()
-i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg
+i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg
 
 -- | only used in defaultLayout; better use siteLayout instead!
 pageHeading :: Route UniWorX -> Maybe Widget
@@ -3113,7 +3127,7 @@ pageHeading _
   = Nothing
 
 
-routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
+routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
 routeNormalizers =
   [ normalizeRender
   , ncSchool
@@ -3124,7 +3138,7 @@ routeNormalizers =
   ]
   where
     normalizeRender route = route <$ do
-      YesodRequest{..} <- liftHandlerT getRequest
+      YesodRequest{..} <- liftHandler getRequest
       let original = (W.pathInfo reqWaiRequest, reqGetParams)
           rendered = renderRoute route
       if
@@ -3320,10 +3334,10 @@ upsertCampusUser ldapData Creds{..} = do
       . UUID.fromByteString
       . fromStrict
       . (convert :: Digest (SHAKE128 128) -> ByteString)
-      . runIdentity
+      . runConduitPure
-      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
+      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash
 
-  [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
+  candidatesRecorded <- E.selectExists . E.from $ \candidate ->
     E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
 
   unless candidatesRecorded $ do
@@ -3401,14 +3415,14 @@ instance YesodAuth UniWorX where
 
     loginHandler = do
       toParent <- getRouteToParent
-      lift . defaultLayout $ do
+      liftHandler . defaultLayout $ do
         plugins <- getsYesod authPlugins
         $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
 
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
-    authenticate Creds{..} = runDB $ do
+    authenticate Creds{..} = liftHandler . runDB $ do
       now <- liftIO getCurrentTime
 
       let
@@ -3477,7 +3491,7 @@ instance YesodAuth UniWorX where
       , dummyLogin <$ guard appAuthDummyLogin
       ]
 
-    authHttpManager = Yesod.getHttpManager
+    authHttpManager = getsYesod appHttpManager
 
     onLogin = addMessageI Success Auth.NowLoggedIn
 

src/Handler/Admin.hs

@@ -54,7 +54,7 @@ instance Button UniWorX ButtonCreate where
   btnClasses CreateInf  = [BCIsButton, BCPrimary]
 -- END Button needed only here
 
-emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
+emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
 emailTestForm = (,)
             <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
             <*> ( MailContext
@@ -112,7 +112,7 @@ postAdminTestR = do
       jId <- queueJob $ JobSendTestEmail email ls
       tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
       return jId
-    writeJobCtl $ JobCtlPerform jId
+    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
     addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
 
   let emailWidget' = wrapForm emailWidget def
@@ -189,7 +189,7 @@ postAdminTestR = do
     -- | How does the shape (`ListLength`) change if a certain cell is deleted?
     deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
                -> ListPosition -- ^ Coordinate to delete
-               -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
+               -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
     deleteCell = miDeleteList
     -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
     allowAdd :: ListPosition -> Natural -> ListLength -> Bool
@@ -374,7 +374,7 @@ postAdminFeaturesR = do
                   -> Getter (DBRow r) (Maybe Text)
                   -> Getter (DBRow r) i
                   -> DBRow r 
-                  -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
+                  -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
     textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
       (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
         <$> mopt textField "" (Just $ row ^. lensDefault)
@@ -385,7 +385,7 @@ postAdminFeaturesR = do
                  -> Getter (DBRow r) Bool
                  -> Getter (DBRow r) i
                  -> DBRow r 
-                 -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
+                 -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
     checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
       ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
         <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)

src/Handler/Allocation/Application.hs

@@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
   { afPriority      :: Maybe Natural
   , afField         :: Maybe StudyFeaturesId
   , afText          :: Maybe Text
-  , afFiles         :: Maybe (Source Handler File)
+  , afFiles         :: Maybe (ConduitT () File Handler ())
   , afRatingVeto    :: Bool
   , afRatingPoints  :: Maybe ExamGrade
   , afRatingComment :: Maybe Text
@@ -77,11 +77,11 @@ applicationForm :: (Maybe AllocationId)
                 -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
 applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
   
-  (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
+  (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
     mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
     coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
     course <- getJust cid
-    [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
+    (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
       E.where_ $ courseApplication E.^. CourseApplicationCourse     E.==. E.val cid
            E.&&. courseApplication E.^. CourseApplicationUser       E.==. E.val uid
            E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
@@ -146,7 +146,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
       -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
 
   hasFiles <- for mApp $ \(Entity appId _)
-    -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
+    -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
   appCID <- for mApp $ encrypt . entityKey
   let appFilesInfo = (,) <$> hasFiles <*> appCID
 
@@ -296,7 +296,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
               fId <- insert file
               insert_ $ CourseApplicationFile appId fId
           forM_ afFiles $ \afFiles' ->
-            runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
+            runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
           audit $ TransactionCourseApplicationEdit cid uid appId
           addMessageI Success $ MsgCourseApplicationCreated courseShorthand
       | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
@@ -327,7 +327,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
                             fId <- lift $ insert file
                             lift . insert_ $ CourseApplicationFile appId fId
                             modify $ Set.insert fId
-                 in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
+                 in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
               deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
               return changes
             | otherwise

src/Handler/Allocation/List.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.Allocation.List
   ( getAllocationListR
   ) where

src/Handler/Allocation/Show.hs

@@ -68,10 +68,10 @@ getAShowR tid ssh ash = do
           let Entity cid Course{..}  = cEntry ^. resultCourse
               hasApplicationTemplate = cEntry ^. resultHasTemplate
               mApp                   = cEntry ^? resultCourseApplication
-          cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
+          cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
           mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
           isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
-          mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
+          mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
           tRoute <- case mApp of
             Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
             Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR

src/Handler/Corrections.hs

@@ -1,6 +1,6 @@
 module Handler.Corrections where
 
-import Import
+import Import hiding (link)
 -- import System.FilePath (takeFileName)
 
 import Jobs
@@ -71,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
     E.where_ $ whereClause t
     return $ returnStatement t
 
-lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit))
+lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
-  => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
+  => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
 lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
   E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
   return $ E.max_ $ edit E.^. SubmissionEditTime
@@ -216,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
   )
 
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
-colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id
+colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
 
@@ -238,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
                         )
             in (submission, sheet, crse, corrector, lastEditQuery submission)
           )
-      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData
       dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector,  E.Value mbLastEdit) -> do
         submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
           E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
@@ -398,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData
                            | CorrAutoSetCorrectorData SheetId
                            | CorrDeleteData
 
-correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
+correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
-  Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
+  currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
 
   postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
     { drAbort = SomeRoute currentRoute
@@ -416,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
       , dbParamsFormAdditional = \frag -> do
           (actionRes, action) <- multiActionM actions "" Nothing mempty
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-      , dbParamsFormEvaluate = liftHandlerT . runFormPost
+      , dbParamsFormEvaluate = liftHandler . runFormPost
       , dbParamsFormResult = _1
       , dbParamsFormIdent = def
       }
@@ -466,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
                     ]
           addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
           auditAllSubEdit sIds
-        (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
+        selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
             E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
             E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
                 E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
@@ -537,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
   where
     authorizedToAssign :: SubmissionId -> DB Bool
     authorizedToAssign sId = do
-      [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
+      (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=<
         E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
           E.on $  sheet E.^. SheetId  E.==. submission E.^. SubmissionSheet
           E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@@ -547,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
       let route  = CSubmissionR tid ssh csh shn cID SubAssignR
       (== Authorized) <$> evalAccessDB route True
 
-type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
+type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
 
 downloadAction, deleteAction :: ActionCorrections'
 downloadAction = ( CorrDownload
@@ -560,7 +560,7 @@ deleteAction = ( CorrDelete
 assignAction :: Either CourseId SheetId -> ActionCorrections'
 assignAction selId = ( CorrSetCorrector
                      , wFormToAForm $ do
-                         correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
+                         correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
                            E.on $   user E.^. UserId   E.==. sheetCorrector E.^. SheetCorrectorUser
                            E.on $  sheet E.^. SheetId  E.==. sheetCorrector E.^. SheetCorrectorSheet
                            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@@ -573,7 +573,7 @@ assignAction selId = ( CorrSetCorrector
 
                          correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
 
-                         cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
+                         cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
                          fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
                      )
 
@@ -740,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do
             }
 
       formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
-        uid <- liftHandlerT requireAuthId
+        uid <- liftHandler requireAuthId
         now <- liftIO getCurrentTime
 
         if
@@ -1013,7 +1013,7 @@ postCorrectionsGradeR = do
         , colCommentField
         ] -- Continue here
       psValidator = def
-        & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
+        & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
       dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
         cID <- encrypt subId

src/Handler/Course/Application/Files.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.Course.Application.Files
   ( getCAFilesR
   , getCAppsFilesR
@@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
 
   let
-    fsSource :: Source DB File
+    fsSource :: ConduitT () File DB ()
     fsSource = do
       apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
         E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation

src/Handler/Course/Application/List.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Handler.Course.Application.List
   ( getCApplicationsR, postCApplicationsR
@@ -103,7 +104,7 @@ instance Csv.ToField CourseApplicationsTableVeto where
 instance Csv.FromField CourseApplicationsTableVeto where
   parseField f = do
     (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
-    return . CourseApplicationsTableVeto $ any (== t)
+    return . CourseApplicationsTableVeto $ elem t
       [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
   
 data CourseApplicationsTableCsv = CourseApplicationsTableCsv

src/Handler/Course/Edit.hs

@@ -44,7 +44,7 @@ data CourseForm = CourseForm
         , cfAllocation  :: Maybe AllocationCourseForm
         , cfAppRequired         :: Bool
         , cfAppInstructions     :: Maybe Html
-        , cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File))
+        , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
         , cfAppText             :: Bool
         , cfAppFiles            :: UploadMode
         , cfAppRatingsVisible   :: Bool
@@ -101,13 +101,13 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
 
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
 makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do
-    -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
+    -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs
     -- let editCid = cfCourseId =<< template -- possible start for refactoring
 
     MsgRenderer mr <- getMsgRenderer
 
-    uid <- liftHandlerT requireAuthId
+    uid <- liftHandler requireAuthId
-    (lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do
+    (lecturerSchools, adminSchools) <- liftHandler . runDB $ do
       lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
       protoAdminSchools  <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
       adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
@@ -116,7 +116,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
 
     termsField <- case template of
           -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
-          (Just cform)  | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
+          (Just cform)  | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course
               _courseOld@Course{..} <- runDB $ get404 cid
               mayEditTerm <- isAuthorized TermEditR True
               mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@@ -128,7 +128,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
         miAdd _ _ nudge btn = Just $ \csrf -> do
           (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
-          addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
+          addRes'  <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk
           let addRes'' = case (,) <$> addRes <*> addRes' of
                 FormSuccess (CI.mk -> email, mLid) ->
                   let new = maybe (Left email) Right mLid
@@ -143,7 +143,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
         miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
         miCell _ (Right lid) defType nudge = \csrf -> do
           (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
-          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
+          User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid
           let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
           return (Just <$> lrwRes,lrwView')
         miCell _ (Left lEmail) defType nudge = \csrf -> do
@@ -153,7 +153,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
 
         miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
                  -> ListPosition -- ^ Coordinate to delete
-                 -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
+                 -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
         miDelete = miDeleteList
 
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
@@ -194,7 +194,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     (newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
         _allIOtherCases -> do
-            mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
+            mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
             return ( (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
                    , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
                    , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )
@@ -202,7 +202,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     let
       allocationForm :: AForm Handler (Maybe AllocationCourseForm)
       allocationForm = wFormToAForm $ do
-        availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
+        availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
           E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
 
           let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid ->
@@ -226,7 +226,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
           activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1
 
           mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
-          mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do
+          mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do
             cID <- encrypt aId :: Handler CryptoUUIDAllocation
             return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
 
@@ -295,7 +295,7 @@ validateCourse = do
   CourseForm{..} <- State.get
 
   now <- liftIO getCurrentTime
-  uid <- liftHandlerT requireAuthId
+  uid <- liftHandler requireAuthId
   userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
   allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
 
@@ -517,7 +517,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                         tell $ Set.singleton fId
                         lift $
                           void . insertUnique $ CourseAppInstructionFile cid fId
-                    keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
+                    keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
                     acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
                     mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
 
@@ -534,7 +534,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         , formEncoding = formEnctype
         }
 
-upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
+upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
 upsertAllocationCourse cid cfAllocation = do
   now <- liftIO getCurrentTime
   Course{..} <- getJust cid

src/Handler/Course/LecturerInvite.hs

@@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..}
   where
     invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
     invitationResolveFor _ = do
-      Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+      case cRoute of
+        Just (CourseR tid csh ssh CLecInviteR) ->
+          getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+        _other -> error "lecturerInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
     invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
+    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
       Nothing    -> areq    (selectField optionsFinite) lFs Nothing
       Just lType -> aforced (selectField optionsFinite) lFs lType
       where

src/Handler/Course/List.hs

@@ -86,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do
         E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
         E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
         return user
-      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
+      dbtProj :: DBRow _ -> MaybeT DB CourseTableData
       dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
         lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
         courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)

src/Handler/Course/ParticipantInvite.hs

@@ -70,13 +70,17 @@ participantInvitationConfig = InvitationConfig{..}
   where
     invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
     invitationResolveFor _ = do
-      Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+      case cRoute of
+        Just (CourseR tid csh ssh CInviteR) ->
+          getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+        _other ->
+          error "participantInvitationConfig called from unsupported route"
     invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
     invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
     invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
@@ -98,9 +102,12 @@ data AddRecipientsResult = AddRecipientsResult
   , aurSuccess              :: [UserEmail]
   } deriving (Read, Show, Generic, Typeable)
 
+instance Semigroup AddRecipientsResult where
+  (<>) = mappenddefault
+
 instance Monoid AddRecipientsResult where
   mempty = memptydefault
-  mappend = mappenddefault
+  mappend = (<>)
 
 getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCAddUserR = postCAddUserR

src/Handler/Course/Register.hs

@@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where
 data CourseRegisterForm = CourseRegisterForm
   { crfStudyFeatures    :: Maybe StudyFeaturesId
   , crfApplicationText  :: Maybe Text
-  , crfApplicationFiles :: Maybe (Source Handler File)
+  , crfApplicationFiles :: Maybe (ConduitT () File Handler ())
   }
 
 courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
 -- ^ `CourseRegisterForm` for current user
-courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
+courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
   muid <- maybeAuthId
   (registration, application) <- runDB $ do
     registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
@@ -108,7 +108,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
         -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
 
     hasFiles <- for application $ \(Entity appId _)
-      -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
+      -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
     appCID <- for application $ encrypt . entityKey
     let appFilesInfo = (,) <$> hasFiles <*> appCID
         filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
@@ -191,7 +191,7 @@ postCRegisterR tid ssh csh = do
             whenIsJust appRes $ 
               audit . TransactionCourseApplicationEdit cid uid 
             whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
-              runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
+              runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
             return appRes
         | otherwise
         = return $ Just ()

src/Handler/Course/Show.hs

@@ -125,11 +125,12 @@ getCShowR tid ssh csh = do
           , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
               Nothing -> mempty
               Just tutorialCapacity' -> sqlCell $ do
-                [E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
+                freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
-                                                           E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
+                  . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
-                                                           return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+                                     E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
-                                                      in return $ E.val tutorialCapacity' E.-. numParticipants
+                                     return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
-                return . toWidget . tshow $ max 0 freeCapacity
+                                in return $ E.val tutorialCapacity' E.-. numParticipants
+                return . toWidget $ tshow freeCapacity
           , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
               mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
               isRegistered <- case mbAid of
@@ -137,7 +138,7 @@ getCShowR tid ssh csh = do
                 Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
               if
                 | mayRegister -> do
-                    (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+                    (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
                     return $ wrapForm tutRegisterForm def
                       { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
                       , formEncoding = tutRegisterEnctype
@@ -198,7 +199,7 @@ getCShowR tid ssh csh = do
           --       Just uid -> existsBy $ UniqueExamRegistration eId uid
           --     if
           --       | mayRegister -> do
-          --           (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
+          --           (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
           --           return $ wrapForm examRegisterForm def
           --             { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
           --             , formEncoding = examRegisterEnctype

src/Handler/Course/User.hs

@@ -159,7 +159,7 @@ postCUserR tid ssh csh uCId = do
           addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
           redirect currentRoute
         Nothing -> invalidArgs ["User already registered"]
-    _other -> fail "Invalid @regButton@"
+    _other -> error "Invalid @regButton@"
 
   mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
 

src/Handler/Course/Users.hs

@@ -139,7 +139,7 @@ makeCourseUserTable :: forall h acts.
                     -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
                     -> DB (FormResult (Element acts, Set UserId), Widget)
 makeCourseUserTable cid acts restrict colChoices psValidator = do
-    Just currentRoute <- liftHandlerT getCurrentRoute
+    currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
     -- -- psValidator has default sorting and filtering
     let dbtIdent     = "courseUsers" :: Text
         dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -210,7 +210,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
               = renderAForm FormStandard
                    $  (, mempty) . First . Just
                   <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
-          , dbParamsFormEvaluate = liftHandlerT . runFormPost
+          , dbParamsFormEvaluate = liftHandler . runFormPost
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
           }

src/Handler/Exam/AddUser.hs

@@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult
   , aurSuccessCourse        :: [UserEmail]
   } deriving (Read, Show, Generic, Typeable)
 
+instance Semigroup AddRecipientsResult where
+  (<>) = mappenddefault
+
 instance Monoid AddRecipientsResult where
   mempty = memptydefault
-  mappend = mappenddefault
+  mappend = (<>)
 
 
 getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
@@ -40,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
     eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
     ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
       now <- liftIO getCurrentTime
-      occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
+      occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
       
       let
         localNow = utcToLocalTime now

src/Handler/Exam/CorrectorInvite.hs

@@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 examCourse
       return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
     invitationResolveFor _ = do
-      Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      fetchExamId tid csh ssh examn
+      case cRoute of
+        Just (CExamR tid csh ssh examn ECInviteR) ->
+          fetchExamId tid csh ssh examn
+        _other ->
+          error "examCorrectorInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Exam{..}) _ = do
       Course{..} <- get404 examCourse
       return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionExamCorrector, ())

src/Handler/Exam/Edit.hs

@@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do
           ExamPartForm{ epfId = Nothing, .. } -> insert_
             ExamPart
               { examPartExam = eId
+              , examPartNumber = epfNumber
               , examPartName = epfName
               , examPartMaxPoints = epfMaxPoints
               , examPartWeight = epfWeight
@@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do
             guard $ examPartExam oldPart == eId
             lift $ replace epfId' ExamPart
               { examPartExam = eId
+              , examPartNumber = epfNumber
               , examPartName = epfName
               , examPartMaxPoints = epfMaxPoints
               , examPartWeight = epfWeight

src/Handler/Exam/Form.hs

@@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 data ExamForm = ExamForm
   { efName :: ExamName
   , efDescription :: Maybe Html
+  , efShowGrades :: Bool
   , efStart :: Maybe UTCTime
   , efEnd :: Maybe UTCTime
   , efVisibleFrom :: Maybe UTCTime
@@ -35,11 +36,10 @@ data ExamForm = ExamForm
   , efPublishOccurrenceAssignments :: Maybe UTCTime
   , efFinished :: Maybe UTCTime
   , efOccurrences :: Set ExamOccurrenceForm
-  , efShowGrades :: Bool
   , efPublicStatistics :: Bool
-  , efGradingRule :: ExamGradingRule
+  , efGradingRule :: Maybe ExamGradingRule
-  , efBonusRule :: ExamBonusRule
+  , efBonusRule :: Maybe ExamBonusRule
-  , efOccurrenceRule :: ExamOccurrenceRule
+  , efOccurrenceRule :: Maybe ExamOccurrenceRule
   , efCorrectors :: Set (Either UserEmail UserId)
   , efExamParts :: Set ExamPartForm
   }
@@ -56,7 +56,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm
 
 data ExamPartForm = ExamPartForm
   { epfId :: Maybe CryptoUUIDExamPart
-  , epfName :: ExamPartName
+  , epfNumber :: ExamPartNumber
+  , epfName :: Maybe ExamPartName
   , epfMaxPoints :: Maybe Points
   , epfWeight :: Rational
   } deriving (Read, Show, Eq, Ord, Generic, Typeable)
@@ -79,6 +80,7 @@ examForm template html = do
   flip (renderAForm FormStandard) html $ ExamForm
     <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
     <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
+    <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
     <*  aformSection MsgExamFormTimes
     <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
     <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
@@ -91,11 +93,10 @@ examForm template html = do
     <*  aformSection MsgExamFormOccurrences
     <*> examOccurrenceForm (efOccurrences <$> template)
     <*  aformSection MsgExamFormAutomaticFunctions
-    <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
     <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
-    <*> examGradingRuleForm (efGradingRule <$> template)
+    <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
-    <*> examBonusRuleForm (efBonusRule <$> template)
+    <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
-    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
+    <*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template)
     <*  aformSection MsgExamFormCorrection
     <*> examCorrectorsForm (efCorrectors <$> template)
     <*  aformSection MsgExamFormParts
@@ -104,8 +105,8 @@ examForm template html = do
 examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
 examCorrectorsForm mPrev = wFormToAForm $ do
   MsgRenderer mr <- getMsgRenderer
-  Just currentRoute <- getCurrentRoute
+  currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
-  uid <- liftHandlerT requireAuthId
+  uid <- liftHandler requireAuthId
 
   let
     miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
@@ -139,7 +140,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
     miCell' (Left email) =
       $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
     miCell' (Right userId) = do
-      User{..} <- liftHandlerT . runDB $ get404 userId
+      User{..} <- liftHandler . runDB $ get404 userId
       $(widgetFile "widgets/massinput/examCorrectors/cellKnown")
 
     miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
@@ -149,7 +150,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
 
 examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
 examOccurrenceForm prev = wFormToAForm $ do
-  Just currentRoute <- getCurrentRoute
+  currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
   let
     miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
     miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
@@ -191,7 +192,7 @@ examOccurrenceForm prev = wFormToAForm $ do
 
 examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
 examPartsForm prev = wFormToAForm $ do
-  Just currentRoute <- getCurrentRoute
+  currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
   let
     miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
     miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
@@ -200,12 +201,14 @@ examPartsForm prev = wFormToAForm $ do
   where
     examPartForm' nudge mPrev csrf = do
       (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
-      (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev)
+      (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
+      (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev)
       (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
       (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
 
       return ( ExamPartForm
                  <$> epfIdRes
+                 <*> epfNumberRes
                  <*> epfNameRes
                  <*> epfMaxPointsRes
                  <*> epfWeightRes
@@ -217,7 +220,8 @@ examPartsForm prev = wFormToAForm $ do
       (res, formWidget) <- examPartForm' nudge Nothing csrf
       let
         addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
-          | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists]
+          | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
+            -> FormFailure [mr MsgExamPartAlreadyExists]
           | otherwise -> FormSuccess $ pure newDat
       return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
     miCell' nudge dat = examPartForm' nudge (Just dat)
@@ -266,6 +270,7 @@ examFormTemplate (Entity eId Exam{..}) = do
         (Just -> epfId, ExamPart{..}) <- examParts'
         return ExamPartForm
           { epfId
+          , epfNumber    = examPartNumber
           , epfName      = examPartName
           , epfMaxPoints = examPartMaxPoints
           , epfWeight    = examPartWeight

src/Handler/Exam/New.hs

@@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
           [ ExamPart{..}
           | ExamPartForm{..} <- Set.toList efExamParts
           , let examPartExam      = examid
+                examPartNumber    = epfNumber
                 examPartName      = epfName
                 examPartMaxPoints = epfMaxPoints
                 examPartWeight    = epfWeight

src/Handler/Exam/RegistrationInvite.hs

@@ -63,15 +63,19 @@ examRegistrationInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 examCourse
       return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
     invitationResolveFor _ = do
-      Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      fetchExamId tid csh ssh examn
+      case cRoute of
+        Just (CExamR tid csh ssh examn EInviteR) ->
+          fetchExamId tid csh ssh examn
+        _other ->
+          error "examRegistrationInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Exam{..}) _ = do
       Course{..} <- get404 examCourse
       return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
     invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
           itAddAuth
             | not invDBExamRegistrationCourseRegister
@@ -81,8 +85,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
           itStartsAt = Nothing
       return InvitationTokenConfig{..}
     invitationRestriction _ _ = return Authorized
-    invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
+    invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
-      isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
+      isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
       now <- liftIO getCurrentTime
 
       case (isRegistered, invDBExamRegistrationCourseRegister) of

src/Handler/Exam/Show.hs

@@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do
   cTime <- liftIO getCurrentTime
   mUid <- maybeAuthId
 
-  (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
+  (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do
     exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
 
     let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do
     let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
     occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
-    examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
+    examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
 
     resultsRaw <- for mUid $ \uid ->
       E.select . E.from $ \examPartResult -> do
@@ -43,6 +43,7 @@ getEShowR tid ssh csh examn = do
     let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
 
     result <- fmap join . for mUid $ getBy . UniqueExamResult eId
+    bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId
 
     occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
       E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
@@ -62,15 +63,27 @@ getEShowR tid ssh csh examn = do
     registered <- for mUid $ existsBy . UniqueExamRegistration eId
     mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
 
-    occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+    lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
-    return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
+    return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown)
+
+  let occurrenceNamesShown = lecturerInfoShown
+      partNumbersShown = lecturerInfoShown
+      examClosedShown = lecturerInfoShown
+
+      sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ]
+      sumPoints = getSum <$> foldMap (fmap Sum . examPartResultResult . entityVal) results
+
+      noBonus = fromMaybe False $ do
+        guardM $ bonusOnlyPassed <$> examBonusRule
+        return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not
+      
 
   let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
       registerWidget
         | Just isRegistered <- registered
         , mayRegister = Just $ do
-            (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
+            (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
             [whamlet|
               <p>
                 $if isRegistered
@@ -86,6 +99,9 @@ getEShowR tid ssh csh examn = do
         | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
         | otherwise = Nothing
 
+      showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
+      showAchievedPoints = not $ null results
+
   let heading = prependCourseTitle tid ssh csh $ CI.original examName
 
   siteLayoutMsg heading $ do

src/Handler/Exam/Users.hs

@@ -4,7 +4,7 @@ module Handler.Exam.Users
   ( getEUsersR, postEUsersR
   ) where
 
-import Import
+import Import hiding ((<.), (.>))
 
 import Handler.Utils
 import Handler.Utils.Exam
@@ -18,11 +18,13 @@ import Database.Esqueleto.Utils.TH
 
 import qualified Data.Csv as Csv
 
-import Data.Map ((!))
+import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.HashMap.Lazy as HashMap
 
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lens as Text
 
 import qualified Data.Conduit.List as C
@@ -33,9 +35,33 @@ import Numeric.Lens (integral)
 
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 
+import Control.Lens.Indexed ((<.), (.>))
 
-type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+
-type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
+type ExamUserTableExpr = (              E.SqlExpr (Entity ExamRegistration)
+                          `E.InnerJoin` E.SqlExpr (Entity User)
+                         )
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+       `E.LeftOuterJoin` (                  E.SqlExpr (Maybe (Entity CourseParticipant))
+                          `E.LeftOuterJoin` (              E.SqlExpr (Maybe (Entity StudyFeatures))
+                                             `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
+                                             `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+                                            )
+                         )
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+type ExamUserTableData = DBRow ( Entity ExamRegistration
+                               , Entity User
+                               , Maybe (Entity ExamOccurrence)
+                               , Maybe (Entity StudyFeatures)
+                               , Maybe (Entity StudyDegree)
+                               , Maybe (Entity StudyTerms)
+                               , Maybe (Entity ExamBonus)
+                               , Maybe (Entity ExamResult)
+                               , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
+                               , Maybe (Entity CourseUserNote)
+                               )
 
 instance HasEntity ExamUserTableData User where
   hasEntity = _dbrOutput . _2
@@ -47,28 +73,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
 _userTableOccurrence = _dbrOutput . _3
 
 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1)
-
-queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
 
 queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
-queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1)
 
 queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
-queryExamOccurrence = $(sqlLOJproj 5 2)
+queryExamOccurrence = $(sqlLOJproj 6 2)
+
+queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
+queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
+  
+queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
 
 queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
 
 queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
+
+queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
+queryExamBonus = $(sqlLOJproj 6 4)
 
 queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
-queryExamResult = $(sqlLOJproj 5 4)
+queryExamResult = $(sqlLOJproj 6 5)
 
 queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
-queryCourseNote = $(sqlLOJproj 5 5)
+queryCourseNote = $(sqlLOJproj 6 6)
+
+queryExamPart :: forall a.
+                 PersistField a
+              => ExamPartId
+              -> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
+              -> ExamUserTableExpr
+              -> E.SqlExpr (E.Value a)
+queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
+  examRegistration <- asks queryExamRegistration
+
+  lift $ do
+    E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart
+     E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser)
+    E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam
+         E.&&. examPart E.^. ExamPartId E.==. E.val epId
+
+    cont examPart examPartResult
 
 resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
 resultExamRegistration = _dbrOutput . _1
@@ -88,11 +137,48 @@ resultStudyField = _dbrOutput . _6 . _Just
 resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
 resultExamOccurrence = _dbrOutput . _3 . _Just
 
+resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
+resultExamBonus = _dbrOutput . _7 . _Just
+
 resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
-resultExamResult = _dbrOutput . _7 . _Just
+resultExamResult = _dbrOutput . _8 . _Just
+
+resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
+resultExamParts = _dbrOutput . _9 . itraversed
+
+-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
+-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
+
+resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
+resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
+
+resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
+resultExamPartResults = resultExamParts <. _2
 
 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
-resultCourseNote = _dbrOutput . _8 . _Just
+resultCourseNote = _dbrOutput . _10 . _Just
+
+
+resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
+resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
+
+resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
+resultAutomaticExamResult exam examBonus' = folding . runReader $ do
+  parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
+  bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
+  return $ examGrade exam bonus =<< parts'
+
+
+csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
+csvExamPartHeader = prism' toHeader fromHeader
+  where
+    toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber)
+    fromHeader hdr = do
+      tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr
+      review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
+
+    partPrefix = "part-"
+  
 
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Maybe Text
@@ -103,24 +189,46 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserDegree :: Maybe Text
   , csvEUserSemester :: Maybe Int
   , csvEUserOccurrence :: Maybe (CI Text)
-  , csvEUserExercisePoints :: Maybe Points
+  , csvEUserExercisePoints :: Maybe (Maybe Points)
-  , csvEUserExerciseNumPasses :: Maybe Int
+  , csvEUserExerciseNumPasses :: Maybe (Maybe Int)
-  , csvEUserExercisePointsMax :: Maybe Points
+  , csvEUserExercisePointsMax :: Maybe (Maybe Points)
-  , csvEUserExerciseNumPassesMax :: Maybe Int
+  , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
+  , csvEUserBonus :: Maybe (Maybe Points)
+  , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
   , csvEUserExamResult :: Maybe ExamResultPassedGrade
   , csvEUserCourseNote :: Maybe Html
   }
   deriving (Generic)
 makeLenses_ ''ExamUserTableCsv
 
-examUserTableCsvOptions :: Csv.Options
-examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
-
 instance ToNamedRecord ExamUserTableCsv where
-  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+  toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $
+    [ "surname" Csv..= csvEUserSurname
+    , "first-name" Csv..= csvEUserFirstName
+    , "name" Csv..= csvEUserName
+    , "matriculation" Csv..= csvEUserMatriculation
+    , "field" Csv..= csvEUserField
+    , "degree" Csv..= csvEUserDegree
+    , "semester" Csv..= csvEUserSemester
+    , "occurrence" Csv..= csvEUserOccurrence
+    ] ++ catMaybes
+           [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
+           , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses
+           , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax
+           , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax
+           , fmap ("bonus" Csv..=) csvEUserBonus
+           ]
+      ++ examPartResults ++
+    [ "exam-result" Csv..= csvEUserExamResult
+    , "course-note" Csv..= csvEUserCourseNote
+    ]
+    where
+      examPartResults
+        = flip ifoldMap csvEUserExamPartResults $
+            \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult
 
 instance FromNamedRecord ExamUserTableCsv where
-  parseNamedRecord csv -- Manually defined awaiting issue #427
+  parseNamedRecord csv
     = ExamUserTableCsv
       <$> csv .:?? "surname"
       <*> csv .:?? "first-name"
@@ -130,36 +238,66 @@ instance FromNamedRecord ExamUserTableCsv where
       <*> csv .:?? "degree"
       <*> csv .:?? "semester"
       <*> csv .:?? "occurrence"
-      <*> csv .:?? "exercise-points"
+      <*> fmap Just (csv .:?? "exercise-points")
-      <*> csv .:?? "exercise-num-passes"
+      <*> fmap Just (csv .:?? "exercise-num-passes")
-      <*> csv .:?? "exercise-points-max"
+      <*> fmap Just (csv .:?? "exercise-points-max")
-      <*> csv .:?? "exercise-num-passes-max"
+      <*> fmap Just (csv .:?? "exercise-num-passes-max")
+      <*> fmap Just (csv .:?? "bonus")
+      <*> examPartResults
       <*> csv .:?? "exam-result"
       <*> csv .:?? "course-note"
-
+    where
-instance DefaultOrdered ExamUserTableCsv where
+      examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
-  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
+        pNumber <- pNumber' ^? csvExamPartHeader
+        return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
 
 instance CsvColumnsExplained ExamUserTableCsv where
-  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
+  csvColumnsExplanations _ = mconcat
-    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
+    [ single "surname"                 MsgCsvColumnExamUserSurname
-    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName         )
+    , single "first-name"              MsgCsvColumnExamUserFirstName
-    , ('csvEUserName                , MsgCsvColumnExamUserName              )
+    , single "name"                    MsgCsvColumnExamUserName
-    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
+    , single "matriculation"           MsgCsvColumnExamUserMatriculation
-    , ('csvEUserField               , MsgCsvColumnExamUserField             )
+    , single "field"                   MsgCsvColumnExamUserField
-    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree            )
+    , single "degree"                  MsgCsvColumnExamUserDegree
-    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester          )
+    , single "semester"                MsgCsvColumnExamUserSemester
-    , ('csvEUserOccurrence          , MsgCsvColumnExamUserOccurrence        )
+    , single "occurrence"              MsgCsvColumnExamUserOccurrence
-    , ('csvEUserExercisePoints      , MsgCsvColumnExamUserExercisePoints    )
+    , single "exercise-points"         MsgCsvColumnExamUserExercisePoints
-    , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
+    , single "exercise-num-passes"     MsgCsvColumnExamUserExercisePasses
-    , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
+    , single "exercise-points-max"     MsgCsvColumnExamUserExercisePointsMax
-    , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
+    , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
-    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult            )
+    , single "bonus"                   MsgCsvColumnExamUserBonus
-    , ('csvEUserCourseNote          , MsgCsvColumnExamUserCourseNote        )
+    , single "part-*"                  MsgCsvColumnExamUserParts
+    , single "exam-result"             MsgCsvColumnExamUserResult
+    , single "course-note"             MsgCsvColumnExamUserCourseNote
     ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+examUserTableCsvHeader :: ( MonoFoldable mono
+                          , Element mono ~ ExamPartNumber
+                          )
+                       => SheetGradeSummary -> Bool -> mono -> Csv.Header
+examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
+  [ "surname", "first-name", "name"
+  , "matriculation"
+  , "field", "degree", "semester"
+  , "course-note"
+  , "occurrence"
+  ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
+    ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses)
+    ++ bool mempty ["bonus"] doBonus
+    ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
+  [ "exam-result"
+  ]
+  where
+    showPasses = numSheetsPasses allBoni /= 0
+    showPoints = getSum (numSheetsPoints allBoni) /= 0
 
 data ExamUserAction = ExamUserDeregister
                     | ExamUserAssignOccurrence
+                    | ExamUserAcceptComputedResult
+                    | ExamUserResetToComputedResult
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe ExamUserAction
@@ -169,13 +307,21 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
 
 data ExamUserActionData = ExamUserDeregisterData
                         | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
+                        | ExamUserAcceptComputedResultData
+                        | ExamUserResetToComputedResultData
+                          { examUserResetBonus :: Bool
+                          }
 
 data ExamUserCsvActionClass
   = ExamUserCsvCourseRegister
   | ExamUserCsvRegister
   | ExamUserCsvAssignOccurrence
   | ExamUserCsvSetCourseField
+  | ExamUserCsvSetPartResult
+  | ExamUserCsvSetBonus
+  | ExamUserCsvOverrideBonus
   | ExamUserCsvSetResult
+  | ExamUserCsvOverrideResult
   | ExamUserCsvSetCourseNote
   | ExamUserCsvDeregister
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -202,8 +348,19 @@ data ExamUserCsvAction
   | ExamUserCsvDeregisterData
     { examUserCsvActRegistration :: ExamRegistrationId
     }
-  | ExamUserCsvSetResultData
+  | ExamUserCsvSetPartResultData
     { examUserCsvActUser :: UserId
+    , examUserCsvActExamPart :: ExamPartNumber
+    , examUserCsvActExamPartResult :: Maybe ExamResultPoints
+    }
+  | ExamUserCsvSetBonusData
+    { examUserCsvIsBonusOverride :: Bool
+    , examUserCsvActUser :: UserId
+    , examUserCsvActExamBonus :: Maybe Points
+    }
+  | ExamUserCsvSetResultData
+    { examUserCsvIsResultOverride :: Bool
+    , examUserCsvActUser :: UserId
     , examUserCsvActExamResult :: Maybe ExamResultPassedGrade
     }
   | ExamUserCsvSetCourseNoteData
@@ -230,75 +387,148 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
-  ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do
+  (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do
-    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+    exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
+    examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
     bonus <- examBonus exam
 
     let
+      allBoni :: SheetGradeSummary
       allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
-      showPasses     = numSheetsPasses allBoni /= 0
+
-      showPoints     = getSum (numSheetsPoints allBoni) /= 0
+      doBonus = is _Just examBonusRule
+      showPasses = doBonus && numSheetsPasses allBoni /= 0
+      showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
 
       resultView :: ExamResultGrade -> ExamResultPassedGrade
       resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
 
+      examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
+
+      resultAutomaticExamBonus' :: Fold ExamUserTableData Points
+      resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
+      resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
+      resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
+
+      automaticCell :: forall msg m a b r.
+                       ( RenderMessage UniWorX msg
+                       , IsDBTable m a
+                       , Eq msg
+                       , Monoid b
+                       , a ~ (Any, b)
+                       )
+                    => Getting (Endo [Either msg msg]) r (Either msg msg)
+                    -> r
+                    -> DBCell m a
+      automaticCell l r = case toListOf l r of
+        [] -> mempty
+        (Left auto : _)
+          -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty)
+        (Right man : others)
+          | all ((== man) . either id id) others
+            -> i18nCell man
+          | otherwise
+            -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty)
+
     csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
 
     let
       examUsersDBTable = DBTable{..}
         where
-          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do
+          dbtSQLQuery = runReaderT $ do
-            E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
+            examRegistration  <- asks queryExamRegistration
-             E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
+            user              <- asks queryUser
-            E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
+            occurrence        <- asks queryExamOccurrence
-             E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
+            courseParticipant <- asks queryCourseParticipant
-            E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+            studyFeatures     <- asks queryStudyFeatures
-            E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+            studyDegree       <- asks queryStudyDegree
-            E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+            studyField        <- asks queryStudyField
-            E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+            examBonus'        <- asks queryExamBonus
-             E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
+            examResult        <- asks queryExamResult
-            E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+            courseUserNote    <- asks queryCourseNote
-             E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+
-            E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+            lift $ do
-            E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+              E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
-            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
+               E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
+              E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
+               E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
+              E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
+               E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
+              E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+              E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+              E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+              E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+               E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
+              E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+               E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+              E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+
+              E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+
+            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
           dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
-          dbtProj = return
+          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+            (,,,,,,,,,)
+              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
+              <*> getExamParts
+              <*> view _9
+            where
+              getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
+              getExamParts = do
+                uid <- view $ _2 . _entityKey
+                rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
+                  E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
+                   E.&&. examPartResult E.?. ExamPartResultUser     E.==. E.just (E.val uid)
+                  E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid
+                  return (examPart, examPartResult)
+                return $ Map.fromList
+                  [ (epId, (examPart, mbRes))
+                  | (Entity epId examPart, mbRes) <- rawResults
+                  ]
+            
           dbtColonnade = mconcat $ catMaybes
-            [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
+            [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
             , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
             , pure   colUserMatriclenr
             , pure $ colField            resultStudyField
             , pure $ colDegreeShort      resultStudyDegree
             , pure $ colFeaturesSemester resultStudyFeatures
             , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
-            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> 
-                SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
+                let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
-                SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
+                    SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
-                return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
+                 in propCell (getSum achievedPasses) (getSum numSheetsPasses)
-            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) ->
-                SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
+                let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus
-                SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
+                    SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
-                return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
+                 in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
-            , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
+            , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
-            , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
+            , pure $ mconcat 
+              [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
+              | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
+              ]
+            , pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
             , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
                 -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
             ]
-          dbtSorting = Map.fromList
+          dbtSorting = mconcat
-            [ sortUserNameLink     queryUser
+            [ uncurry singletonMap $ sortUserNameLink     queryUser
-            , sortUserMatriclenr   queryUser
+            , uncurry singletonMap $ sortUserMatriclenr   queryUser
-            , sortField            queryStudyField
+            , uncurry singletonMap $ sortField            queryStudyField
-            , sortDegreeShort      queryStudyDegree
+            , uncurry singletonMap $ sortDegreeShort      queryStudyDegree
-            , sortFeaturesSemester queryStudyFeatures
+            , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
-            , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , mconcat
-            , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
+              [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
-            , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
+              | Entity epId ExamPart{..} <- examParts
-            , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
+              ]
+            , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
+            , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
+            , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
+            , singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
+            , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
                 E.sub_select . E.from $ \edit -> do
                   E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                   return . E.max_ $ edit E.^. CourseUserNoteEditTime
-              )
             ]
           dbtFilter = Map.fromList
             [ fltrUserNameEmail    queryUser
@@ -341,39 +571,55 @@ postEUsersR tid ssh csh examn = do
             , dbParamsFormAdditional = \csrf -> do
                 let
                   actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
-                  actionMap = Map.fromList
+                  actionMap = mconcat
-                    [ ( ExamUserDeregister
+                    [ singletonMap ExamUserDeregister $
-                      , pure ExamUserDeregisterData
+                        pure ExamUserDeregisterData
-                      )
+                    , singletonMap ExamUserAssignOccurrence $
-                    , ( ExamUserAssignOccurrence
+                        ExamUserAssignOccurrenceData
-                      , ExamUserAssignOccurrenceData
                         <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
-                      )
+                    , bool mempty computeActionMap $ is _Just examGradingRule
+                    ]
+                  computeActionMap = mconcat
+                    [ singletonMap ExamUserAcceptComputedResult $
+                        pure ExamUserAcceptComputedResultData
+                    , singletonMap ExamUserResetToComputedResult $
+                        ExamUserResetToComputedResultData
+                        <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
                     ]
                 (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
                 let formRes = (, mempty) . First . Just <$> res
                 return (formRes, formWgt)
-            , dbParamsFormEvaluate = liftHandlerT . runFormPost
+            , dbParamsFormEvaluate = liftHandler . runFormPost
-            , dbParamsFormResult   = id
+            , dbParamsFormResult   = _2
             , dbParamsFormIdent    = def
             }
           dbtIdent :: Text
           dbtIdent = "exam-users"
-          dbtCsvEncode = simpleCsvEncode csvName $ ExamUserTableCsv
+          dbtCsvEncode = Just DBTCsvEncode
-            <$> view (resultUser . _entityVal . _userSurname . to Just)
+            { dbtCsvExportForm   = pure ()
-            <*> view (resultUser . _entityVal . _userFirstName . to Just)
+            , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
+            , dbtCsvName         = unpack csvName
-            <*> view (resultUser . _entityVal . _userMatrikelnummer)
+            , dbtCsvNoExportData = Just id
-            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+            , dbtCsvHeader       = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
-            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+            }
-            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+            where
-            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+              doEncode' = ExamUserTableCsv
-            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
+                <$> view (resultUser . _entityVal . _userSurname . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
+                <*> view (resultUser . _entityVal . _userFirstName . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
+                <*> view (resultUser . _entityVal . _userDisplayName . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
+                <*> view (resultUser . _entityVal . _userMatrikelnummer)
-            <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
+                <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
-            <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
+                <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+                <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+                <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+                <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints)
+                <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
+                <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints)
+                <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
+                <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
+                <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
+                <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
+                <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
           dbtCsvDecode = Just DBTCsvDecode
             { dbtCsvRowKey = \csv -> do
                 uid <- lift $ view _2 <$> guessUser csv
@@ -382,20 +628,28 @@ postEUsersR tid ssh csh examn = do
                 DBCsvDiffMissing{dbCsvOldKey}
                   -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
                 DBCsvDiffNew{dbCsvNewKey = Just _}
-                  -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
+                  -> 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
                   if
                     | isPart -> do
                         yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
                         newFeatures <- lift $ lookupStudyFeatures dbCsvNew
-                        Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
+                        Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
                         when (newFeatures /= oldFeatures) $
                           yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
                     | otherwise ->
                         yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
+
+                  iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
+                    when (epNumber `elem` examPartNumbers) $
+                      yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
+            
+                  when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
+                    yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
+            
                   when (is _Just $ csvEUserExamResult dbCsvNew) $
-                    yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
+                    yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
 
                   note <- lift . getBy $ UniqueCourseUserNote uid examCourse
                   when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
@@ -407,11 +661,54 @@ postEUsersR tid ssh csh examn = do
 
                   newFeatures <- lift $ lookupStudyFeatures dbCsvNew
                   when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
-                    Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
+                    Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
                     yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
 
-                  when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
+                  let uid = dbCsvOld ^. resultUser . _entityKey
-                    yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
+
+                  forM_ examPartNumbers $ \epNumber ->
+                    let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult
+                     in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes ->
+                          when (epRes /= oldPartResult) $
+                            yield $ ExamUserCsvSetPartResultData uid epNumber epRes
+
+                  let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
+                      newResults = sequence (csvEUserExamPartResults dbCsvNew)
+                               <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
+
+                      newBonus, oldBonus :: Maybe Points
+                      newBonus = join (csvEUserBonus dbCsvNew)
+                      oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
+
+                      newResult, oldResult :: Maybe ExamResultPassedGrade
+                      newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
+                      oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
+                  
+                  when doBonus $
+                    case newBonus of
+                      _ | newBonus == oldBonus
+                          -> return ()
+                      _ | is _Nothing newBonus
+                          -> return ()
+                      Nothing
+                        -> yield $ ExamUserCsvSetBonusData False uid newBonus
+                      Just _
+                        -> yield $ ExamUserCsvSetBonusData True uid newBonus
+            
+                  case newResult of
+                    _ | csvEUserExamResult dbCsvNew == oldResult
+                        -> return ()
+                    _ | is _Nothing $ csvEUserExamResult dbCsvNew
+                        -> return ()
+                    Nothing
+                      -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+                    Just _
+                      | csvEUserExamResult dbCsvNew /= newResult
+                        -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
+                      | oldResult /= newResult
+                        -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+                      | otherwise
+                        -> return ()
 
                   when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
                     yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
@@ -421,7 +718,13 @@ postEUsersR tid ssh csh examn = do
                 ExamUserCsvDeregisterData{}       -> ExamUserCsvDeregister
                 ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
                 ExamUserCsvSetCourseFieldData{}   -> ExamUserCsvSetCourseField
-                ExamUserCsvSetResultData{}        -> ExamUserCsvSetResult
+                ExamUserCsvSetPartResultData{}    -> ExamUserCsvSetPartResult
+                ExamUserCsvSetBonusData{..}
+                  | examUserCsvIsBonusOverride    -> ExamUserCsvOverrideBonus
+                  | otherwise                     -> ExamUserCsvSetBonus
+                ExamUserCsvSetResultData{..}
+                  | examUserCsvIsResultOverride   -> ExamUserCsvOverrideResult
+                  | otherwise                     -> ExamUserCsvSetResult
                 ExamUserCsvSetCourseNoteData{}    -> ExamUserCsvSetCourseNote
             , dbtCsvCoarsenActionClass = \case
                 ExamUserCsvCourseRegister -> DBCsvActionNew
@@ -462,6 +765,34 @@ postEUsersR tid ssh csh examn = do
                     update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
                     CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
                     audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
+                  ExamUserCsvSetPartResultData{..} -> do
+                    epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
+                    case examUserCsvActExamPartResult of
+                      Nothing  -> do
+                        deleteBy $ UniqueExamPartResult epid examUserCsvActUser
+                        audit $ TransactionExamPartResultDeleted epid examUserCsvActUser
+                      Just res -> do
+                        now <- liftIO getCurrentTime
+                        void $ upsertBy
+                          (UniqueExamPartResult epid examUserCsvActUser)
+                          (ExamPartResult epid examUserCsvActUser res now)
+                          [ ExamPartResultResult =. res
+                          , ExamPartResultLastChanged =. now
+                          ]
+                        audit $ TransactionExamPartResultEdit epid examUserCsvActUser
+                  ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of
+                    Nothing  -> do
+                      deleteBy $ UniqueExamBonus eid examUserCsvActUser
+                      audit $ TransactionExamBonusDeleted eid examUserCsvActUser
+                    Just res -> do
+                      now <- liftIO getCurrentTime
+                      void $ upsertBy
+                        (UniqueExamBonus eid examUserCsvActUser)
+                        (ExamBonus eid examUserCsvActUser res now)
+                        [ ExamBonusBonus =. res
+                        , ExamBonusLastChanged =. now
+                        ]
+                      audit $ TransactionExamBonusEdit eid examUserCsvActUser
                   ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
                     Nothing  -> do
                       deleteBy $ UniqueExamResult eid examUserCsvActUser
@@ -491,13 +822,13 @@ postEUsersR tid ssh csh examn = do
                       delete nid
                   ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
                     now <- liftIO getCurrentTime
-                    uid <- liftHandlerT requireAuthId
+                    uid <- liftHandler requireAuthId
                     Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
                     insert_ $ CourseUserNoteEdit uid now nid
                 return $ CExamR tid ssh csh examn EUsersR
             , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
                 ExamUserCsvCourseRegisterData{..} -> do
-                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+                  (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                   [whamlet|
                     $newline never
                     ^{nameWidget userDisplayName userSurname}
@@ -511,7 +842,7 @@ postEUsersR tid ssh csh examn = do
                       \ (_{MsgExamNoOccurrence})
                   |]
                 ExamUserCsvRegisterData{..} -> do
-                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+                  (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                   [whamlet|
                     $newline never
                     ^{nameWidget userDisplayName userSurname}
@@ -521,7 +852,7 @@ postEUsersR tid ssh csh examn = do
                       \ (_{MsgExamNoOccurrence})
                   |]
                 ExamUserCsvAssignOccurrenceData{..} -> do
-                  occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
+                  occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
                   [whamlet|
                     $newline never
                     ^{registeredUserName' examUserCsvActRegistration}
@@ -531,7 +862,7 @@ postEUsersR tid ssh csh examn = do
                       \ (_{MsgExamNoOccurrence})
                   |]
                 ExamUserCsvSetCourseFieldData{..} -> do
-                  User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
+                  User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
                   [whamlet|
                     $newline never
                     ^{nameWidget userDisplayName userSurname}
@@ -540,8 +871,34 @@ postEUsersR tid ssh csh examn = do
                     $nothing
                       , _{MsgCourseStudyFeatureNone}
                   |]
+                ExamUserCsvSetPartResultData{..} -> do
+                  (User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
+                    (,) <$> getJust examUserCsvActUser
+                        <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe pName <- examPartName
+                      , „#{pName}“
+                    $nothing
+                      , _{MsgExamPartNumbered examPartNumber}
+                    $maybe newResult <- examUserCsvActExamPartResult
+                      , _{newResult}
+                    $nothing
+                      , _{MsgExamResultNone}
+                  |]
+                ExamUserCsvSetBonusData{..} -> do
+                  User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe newBonus <- examUserCsvActExamBonus
+                      , _{newBonus}
+                    $nothing
+                      , _{MsgExamBonusNone}
+                  |]
                 ExamUserCsvSetResultData{..} -> do
-                  User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+                  User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
                   [whamlet|
                     $newline never
                     ^{nameWidget userDisplayName userSurname}
@@ -551,7 +908,7 @@ postEUsersR tid ssh csh examn = do
                       , _{MsgExamResultNone}
                   |]
                 ExamUserCsvSetCourseNoteData{..} -> do
-                  User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+                  User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
                   [whamlet|
                     $newline never
                     ^{nameWidget userDisplayName userSurname}
@@ -651,21 +1008,21 @@ postEUsersR tid ssh csh examn = do
       examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
                                       & defaultPagesize PagesizeAll
 
-      postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
+      postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData)
       postprocess inp = do
         (First (Just act), regMap) <- inp
-        let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
+        let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
-        return (act, regSet)
+        return (act, regMap')
-    (, exam) . over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
+    (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
 
   formResult registrationResult $ \case
-    (ExamUserDeregisterData, selectedRegistrations) -> do
+    (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do
       nrDel <- runDB $ deleteWhereCount
         [ ExamRegistrationId <-. Set.toList selectedRegistrations
         ]
       addMessageI Success $ MsgExamUsersDeregistered nrDel
       redirect $ CExamR tid ssh csh examn EUsersR
-    (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
+    (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
       nrUpdated <- runDB $ updateWhereCount
         [ ExamRegistrationId <-. Set.toList selectedRegistrations
         ]
@@ -673,9 +1030,67 @@ postEUsersR tid ssh csh examn = do
         ]
       addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
       redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserAcceptComputedResultData, Map.elems -> rows) -> do
+      nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
+        now <- liftIO getCurrentTime
+        uid <- view $ resultUser . _entityKey
+        hasResult <- asks $ has resultExamResult
+        hasBonus <- asks $ has resultExamBonus
+        autoResult <- preview $ resultAutomaticExamResult examVal bonus
+        autoBonus <- preview $ resultAutomaticExamBonus examVal bonus
+        lift $ if
+          | not hasResult
+          , Just examResultResult <- autoResult
+            -> do
+              if
+                | Just examBonusBonus <- autoBonus
+                , not hasBonus
+                -> do
+                  insert_ ExamBonus
+                    { examBonusExam = eId
+                    , examBonusUser = uid
+                    , examBonusLastChanged = now
+                    , ..
+                    }
+                  audit $ TransactionExamBonusEdit eId uid
+                | otherwise
+                -> return ()
+              
+              insert_ ExamResult
+                { examResultExam = eId
+                , examResultUser = uid
+                , examResultLastChanged = now
+                , ..
+                }
+              audit $ TransactionExamResultEdit eId uid
+              return $ Sum 1
+          | otherwise
+            -> return mempty
+      addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted
+      redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do
+      nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
+        uid <- view $ resultUser . _entityKey
+        lift $ do
+          when examUserResetBonus $ do
+            bonusId' <- getKeyBy $ UniqueExamBonus eId uid
+            whenIsJust bonusId' $ \bonusId -> do
+                delete bonusId
+                audit $ TransactionExamBonusDeleted eId uid
+
+          result <- getKeyBy $ UniqueExamResult eId uid
+          case result of
+            Just resId -> do
+              delete resId
+              audit $ TransactionExamResultDeleted eId uid
+              return $ Sum 1
+            Nothing -> return mempty
+      addMessageI Success $ MsgExamUsersResultsReset nrReset
+      redirect $ CExamR tid ssh csh examn EUsersR
 
   closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
+    let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip")
     $(widgetFile "exam-users")

src/Handler/ExamOffice/Course.hs

@@ -16,7 +16,7 @@ import Handler.Utils
 examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId)
 -- ^ Deals with sets of _opt outs_
 examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do
-  schools <- liftHandlerT . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
+  schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
 
   res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced)
     -> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template)

src/Handler/ExamOffice/Exam.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.ExamOffice.Exam
   ( getEGradesR, postEGradesR
   , examCloseWidget
@@ -84,7 +86,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult
                                )
 
 queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration)))
-queryExamRegistration = to $ $(E.sqlLOJproj 4 2)
+queryExamRegistration = to $(E.sqlLOJproj 4 2)
 
 queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User))
 queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)
@@ -213,7 +215,7 @@ postEGradesR tid ssh csh examn = do
           partAnchor :: Widget
           partAnchor = do
             let partId = x ^. resultUser . _entityKey
-            cID <- encrypt partId :: WidgetT UniWorX IO CryptoUUIDUser
+            cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser
             [whamlet|
               $newline never
               <span ##{toPathPiece cID}>
@@ -262,6 +264,7 @@ postEGradesR tid ssh csh examn = do
               E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
                E.&&. occurrence E.?. ExamOccurrenceId   E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
               E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
+               E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid)
               E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
                E.&&. examResult E.^. ExamResultExam E.==. E.val eid
 
@@ -385,7 +388,7 @@ postEGradesR tid ssh csh examn = do
                 (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
                 let formRes = (, mempty) . First . Just <$> res
                 return (formRes, formWgt)
-            , dbParamsFormEvaluate = liftHandlerT . runFormPost
+            , dbParamsFormEvaluate = liftHandler . runFormPost
             , dbParamsFormResult   = id
             , dbParamsFormIdent    = def
             }
@@ -408,6 +411,7 @@ postEGradesR tid ssh csh examn = do
                   (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
             , dbtCsvName = unpack csvName
             , dbtCsvNoExportData = Nothing
+            , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
             }
           dbtCsvDecode = Nothing
 

src/Handler/ExamOffice/Exams.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.ExamOffice.Exams
   ( getEOExamsR
   ) where

src/Handler/ExamOffice/Fields.hs

@@ -45,7 +45,7 @@ eofModeField = Field{..}
 
 makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool)
 makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do
-  availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
+  availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
     E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms
     E.where_ . E.exists . E.from $ \userFunction ->
       E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
@@ -75,7 +75,7 @@ getEOFieldsR = postEOFieldsR
 postEOFieldsR = do
   uid <- requireAuthId
 
-  oldFields <- liftHandlerT . runDB $ do
+  oldFields <- runDB $ do
     fields <- E.select . E.from $ \examOfficeField -> do
       E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
       return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
@@ -84,7 +84,7 @@ postEOFieldsR = do
   ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
 
   formResult fieldsRes $ \newFields -> do
-    liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
+    runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
       | Just forced <- Map.lookup fieldId newFields
       , fieldId `Map.member` oldFields -> do
           updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ]

src/Handler/ExamOffice/Users.hs

@@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
       return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       let itExpiresAt = Nothing
           itStartsAt = Nothing
           itAddAuth = Nothing
@@ -85,7 +85,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
   
 makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
 makeExamOfficeUsersForm template = renderWForm FormStandard $ do
-  Just cRoute <- getCurrentRoute
+  cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
   
   let
     miAdd' :: (Text -> Text)
@@ -105,7 +105,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
     miCell' :: Either UserEmail UserId -> Widget
     miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
     miCell' (Right uid) = do
-      User{..} <- liftHandlerT . runDB $ getJust uid
+      User{..} <- liftHandler . runDB $ getJust uid
       $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
     miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
     miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
@@ -119,7 +119,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
     fRequired :: Bool
     fRequired = False
 
-  template' <- for template $ \uids -> liftHandlerT . runDB $ do
+  template' <- for template $ \uids -> liftHandler . runDB $ do
     let (invitations, knownUsers) = partitionEithers $ Set.toList uids
     knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
       E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
@@ -137,7 +137,7 @@ getEOUsersR = postEOUsersR
 postEOUsersR = do
   uid <- requireAuthId
 
-  oldUsers <- liftHandlerT . runDB $ do
+  oldUsers <- liftHandler . runDB $ do
     users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
       E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
        E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
@@ -148,7 +148,7 @@ postEOUsersR = do
   ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
 
   formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
-    liftHandlerT . runDBJobs . forM_ changes $ \change -> if
+    liftHandler . runDBJobs . forM_ changes $ \change -> if
       | change `Set.member` oldUsers -> case change of
           Right change' -> do
             deleteBy $ UniqueExamOfficeUser uid change'

src/Handler/Health.hs

@@ -27,7 +27,7 @@ getHealthR = do
       waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
       case waitResult of
         Left False -> sendResponseStatus noContent204 ()
-        Left True  -> fail "System is not generating HealthReports"
+        Left True  -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text)
         Right _    -> redirect HealthR
     Just healthReports -> do
       let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports

src/Handler/Home.hs

@@ -58,7 +58,7 @@ homeUpcomingSheets uid = do
                                              , E.Value UTCTime
                                              , E.Value (Maybe SubmissionId)
                                              ))
-                                      (DBCell (HandlerT UniWorX IO) ())
+                                      (DBCell Handler ())
       colonnade = mconcat
         [ -- dbRow
           -- TOOD: sortable (Just "term")   (textCell MsgTerm)   $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
@@ -82,7 +82,7 @@ homeUpcomingSheets uid = do
                                         (hasTickmark True)
         ]
   let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
-  sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
+  sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
     , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
@@ -127,7 +127,7 @@ homeUpcomingSheets uid = do
 homeUpcomingExams :: UserId -> Widget
 homeUpcomingExams uid = do
   now <- liftIO getCurrentTime
-  ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
+  ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
     User {userWarningDays} <- get404 uid
     let fortnight = addUTCTime userWarningDays now
     let -- code copied and slightly adapted from Handler.Course.getCShowR:
@@ -202,7 +202,7 @@ homeUpcomingExams uid = do
                 isRegistered <- existsBy $ UniqueExamRegistration eId uid
                 if
                   | mayRegister -> do
-                      (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+                      (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
                       return $ wrapForm examRegisterForm def
                         { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
                         , formEncoding = examRegisterEnctype

src/Handler/Material.hs

@@ -28,7 +28,7 @@ data MaterialForm = MaterialForm
       , mfType         :: Maybe (CI Text)
       , mfDescription  :: Maybe Html
       , mfVisibleFrom  :: Maybe UTCTime
-      , mfFiles        :: Maybe (Source Handler (Either FileId File))
+      , mfFiles        :: Maybe (ConduitT () (Either FileId File) Handler ())
       }
 
 makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
@@ -40,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
         | Just source <- template >>= mfFiles
                     = runConduit $ source .| C.foldMap setIds
         | otherwise = return Set.empty
-      typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
+      typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
       typeOptions = do
         let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
         previouslyUsed <- runDB $
@@ -77,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do
   getKeyBy404 $  UniqueMaterial cid mnm
 
 fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
-fetchMaterial tid ssh csh mnm = do
+fetchMaterial tid ssh csh mnm =
-  [matEnt] <- E.select . E.from  $ -- uniqueness guaranteed by DB constraints
+  maybe notFound return . listToMaybe <=< E.select . E.from  $ -- uniqueness guaranteed by DB constraints
     \(course `E.InnerJoin` material) -> do
       E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
       E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
@@ -86,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do
           E.&&.  course   E.^. CourseShorthand E.==. E.val csh
           E.&&.  material E.^. MaterialName    E.==. E.val mnm
       return material
-  return matEnt
 
 
 getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -245,7 +244,7 @@ postMEditR tid ssh csh mnm = do
       E.on     $ matFile  E.^. MaterialFileFile     E.==. file E.^. FileId
       E.where_ $ matFile  E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
       return $ file E.^. FileId
-    return (matEnt, (Left . E.unValue) <$> fileIds)
+    return (matEnt, Left . E.unValue <$> fileIds)
   -- let cid = materialCourse
   let template = Just MaterialForm
         { mfName         = materialName
@@ -308,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
       when saveOk $ redirect -- redirect must happen outside of runDB
         $ CourseR tid ssh csh (MaterialR mfName MShowR)
 
-    insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB ()
+    insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB ()
     insertMaterialFile' mid fs = do
         oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
           E.on     $  materialFile E.^. MaterialFileFile E.==. file E.^. FileId
           E.where_ $  materialFile E.^. MaterialFileMaterial E.==. E.val mid
           return $ file E.^. FileId
         let oldFileIds = setFromList $ map E.unValue oldFileIdVals
-        keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
+        keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
         mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
       where
         finsert (Left fileId) = tell $ singleton fileId

src/Handler/Profile.hs

@@ -94,7 +94,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
   where
     schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
     schoolsForm' = do
-      allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
+      allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
 
       let
         schoolForm (Entity ssh School{schoolName})
@@ -116,7 +116,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
 
 notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
 notificationForm template = wFormToAForm $ do
-  mbUid <- liftHandlerT maybeAuthId
+  mbUid <- liftHandler maybeAuthId
   isAdmin <- hasReadAccessTo AdminR
 
   let
@@ -144,7 +144,7 @@ notificationForm template = wFormToAForm $ do
       | otherwise
       = return False
 
-  ntHidden <- liftHandlerT . runDB
+  ntHidden <- liftHandler . runDB
             $ Set.fromList universeF
             & Map.fromSet sectionIsHidden
             & sequenceA

src/Handler/School.hs

@@ -70,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
   <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
   <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
   where
-    ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text))
+    ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
     ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
       setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
 

src/Handler/Sheet.hs

@@ -2,7 +2,7 @@
 
 module Handler.Sheet where
 
-import Import
+import Import hiding (link)
 
 import Jobs.Queue
 
@@ -69,10 +69,7 @@ data SheetForm = SheetForm
       , sfActiveTo     :: UTCTime
       , sfHintFrom     :: Maybe UTCTime
       , sfSolutionFrom :: Maybe UTCTime
-      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
+      , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
-      , sfHintF        :: Maybe (Source Handler (Either FileId File))
-      , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
-      , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
       , sfType         :: SheetType
       , sfGrouping     :: SheetGroup
       , sfSubmissionMode :: SubmissionMode
@@ -93,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
     oldFileIds <- (return.) <$> case msId of
       Nothing    -> return $ partitionFileType mempty
-      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
+      (Just sId) -> liftHandler $ runDB $ getFtIdMap sId
     mr <- getMsgRenderer
     ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
@@ -637,20 +634,20 @@ postSDelR tid ssh csh shn = do
 
 insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
 insertSheetFile sid ftype finfo = do
-    runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
+    runConduit $ sourceFiles finfo .| C.mapM_ finsert
   where
     finsert file = do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
 
-insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
+insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX ()
 insertSheetFile' sid ftype fs = do
     oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
       E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
       E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
            E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
       return (file E.^. FileId)
-    keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
+    keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
     mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
   where
     finsert (Left fileId) = tell $ singleton fileId
@@ -689,13 +686,13 @@ defaultLoads shid = do
     return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
   where
     toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
-    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
+    toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad)
 
 
 correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
 correctorForm shid = wFormToAForm $ do
-  Just currentRoute <- liftHandlerT getCurrentRoute
+  currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
-  userId <- liftHandlerT requireAuthId
+  userId <- liftHandler requireAuthId
   MsgRenderer mr <- getMsgRenderer
 
   let
@@ -703,9 +700,9 @@ correctorForm shid = wFormToAForm $ do
     currentLoads = Map.union
       <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
       <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid)
-  (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+  (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads
 
-  isWrite <- liftHandlerT $ isWriteRequest currentRoute
+  isWrite <- liftHandler $ isWriteRequest currentRoute
 
   let
     applyDefaultLoads = Map.null currentLoads' && not isWrite
@@ -766,7 +763,7 @@ correctorForm shid = wFormToAForm $ do
       identWidget <- case userIdent of
         Left email -> return . toWidget $ mailtoHtml email
         Right uid -> do
-          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
+          User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
           return $ nameEmailWidget userEmail userDisplayName userSurname
       return (res, $(widgetFile "sheetCorrectors/cell"))
 
@@ -812,7 +809,7 @@ correctorForm shid = wFormToAForm $ do
 
         postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
         postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
-        postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
+        postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector))
 
     filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
     filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
@@ -894,18 +891,22 @@ correctorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 sheetCourse
       return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
     invitationResolveFor _ = do
-      Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      fetchSheetId tid csh ssh shn
+      case cRoute of
+        Just (CSheetR tid csh ssh shn SCorrInviteR) ->
+          fetchSheetId tid csh ssh shn
+        _other ->
+          error "correctorInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
     invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
+    invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
     invitationInsertHook _ _ _ _ = id
     invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
     invitationUltDest (Entity _ Sheet{..}) _ = do

src/Handler/Submission.hs

@@ -89,9 +89,13 @@ submissionUserInvitationConfig = InvitationConfig{..}
       cID <- encrypt subId
       return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
     invitationResolveFor _ = do
-      Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      subId <- decrypt cID
+      case cRoute of
-      bool notFound (return subId) =<< existsKey subId
+        Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do
+          subId <- decrypt cID
+          bool notFound (return subId) =<< existsKey subId
+        _other ->
+          error "submissionUserInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
@@ -103,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
     invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
       let itExpiresAt = Nothing
           itStartsAt = Nothing
@@ -121,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
       return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
 
 
-makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
+makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId))
 makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
   <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
   <*> wFormToAForm submittorsForm
@@ -129,7 +133,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
     miCell' :: Markup -> Either UserEmail UserId -> Widget
     miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
     miCell' csrf (Right uid) = do
-      User{..} <- liftHandlerT . runDB $ getJust uid
+      User{..} <- liftHandler . runDB $ getJust uid
       $(widgetFile "widgets/massinput/submissionUsers/cellKnown")
 
     miLayout :: ListLength
@@ -191,7 +195,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
           | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
           | otherwise -> FormSuccess $ Set.fromList submittors'
       | otherwise = do
-        uid <- liftHandlerT requireAuthId
+        uid <- liftHandler requireAuthId
         mRoute <- getCurrentRoute
 
         let
@@ -275,7 +279,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe
 submissionHelper tid ssh csh shn mcid = do
   uid <- requireAuthId
   msmid     <- traverse decrypt mcid
-  Just actionUrl <- getCurrentRoute
+  actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
 
   (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner)  <- runDB $ do
     csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
@@ -478,7 +482,7 @@ submissionHelper tid ssh csh shn mcid = do
     Nothing  -> return ()
 
   -- Maybe construct a table to display uploaded archive files
-  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
+  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
       colonnadeFiles cid = mconcat
         [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
               Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)

src/Handler/SystemMessage.hs

@@ -179,7 +179,7 @@ postMessageListR = do
         { dbrOutput = (smE, smT)
         , ..
         }
-    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
+    psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
   (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtRowKey = (E.^. SystemMessageId)
@@ -216,7 +216,7 @@ postMessageListR = do
                 ]
           (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-      , dbParamsFormEvaluate = liftHandlerT . runFormPost
+      , dbParamsFormEvaluate = liftHandler . runFormPost
       , dbParamsFormResult = id
       , dbParamsFormIdent = def
       }
@@ -225,8 +225,8 @@ postMessageListR = do
     , dbtCsvDecode = Nothing
     }
 
-  let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
+  let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
-                           & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
+                           <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
 
   case tableRes of
     FormMissing -> return ()

src/Handler/Term.hs

@@ -176,7 +176,7 @@ postTermEditExistR tid = do
 
 termEditHandler :: TermFormTemplate -> Handler Html
 termEditHandler term = do
-    Just eHandler <- getCurrentRoute
+    eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
       (FormSuccess res) -> do

src/Handler/Tutorial.hs

@@ -14,6 +14,7 @@ import Handler.Utils.Invitations
 import Jobs.Queue
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 import Data.Map ((!))
@@ -198,7 +199,7 @@ postTCommR tid ssh csh tutn = do
         )
       ]
     , crRecipientAuth = Just $ \uid -> do
-        [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
+        isTutorialUser <- E.selectExists . E.from $ \tutorialUser ->
           E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
                E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
 
@@ -250,15 +251,19 @@ tutorInvitationConfig = InvitationConfig{..}
       Course{..} <- get404 tutorialCourse
       return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
     invitationResolveFor _ = do
-      Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
+      cRoute <- getCurrentRoute
-      fetchTutorialId tid csh ssh tutn
+      case cRoute of
+        Just (CTutorialR tid csh ssh tutn TInviteR) ->
+          fetchTutorialId tid csh ssh tutn
+        _other ->
+          error "tutorInvitationConfig called from unsupported route"
     invitationSubject (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
     invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionTutor, ())
@@ -289,8 +294,8 @@ data TutorialForm = TutorialForm
 tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
 tutorialForm cid template html = do
   MsgRenderer mr <- getMsgRenderer
-  Just cRoute <- getCurrentRoute
+  cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
-  uid <- liftHandlerT requireAuthId
+  uid <- liftHandler requireAuthId
 
   let
     tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
@@ -314,7 +319,7 @@ tutorialForm cid template html = do
         miCell' (Left email) =
           $(widgetFile "tutorial/tutorMassInput/cellInvitation")
         miCell' (Right userId) = do
-          User{..} <- liftHandlerT . runDB $ get404 userId
+          User{..} <- liftHandler . runDB $ get404 userId
           $(widgetFile "tutorial/tutorMassInput/cellKnown")
 
         miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
@@ -338,7 +343,7 @@ tutorialForm cid template html = do
                             ) (tfDeregisterUntil <$> template)
     <*> tutorForm
   where
-    tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text))
+    tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
     tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
       fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
         E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid

src/Handler/Users.hs

@@ -74,7 +74,7 @@ postUsersR = do
       , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
           sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            schools <- liftHandlerT . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
+            schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
               E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                    E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@@ -92,7 +92,7 @@ postUsersR = do
           , formCellContents = do
               cID <- encrypt uid
               mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
-              myUid <- liftHandlerT maybeAuthId
+              myUid <- liftHandler maybeAuthId
               if
                 | mayHijack
                 , Just uid /= myUid
@@ -191,7 +191,7 @@ postUsersR = do
             = renderAForm FormStandard
                  $  (, mempty) . First . Just
                 <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing
-        , dbParamsFormEvaluate = liftHandlerT . runFormPost
+        , dbParamsFormEvaluate = liftHandler . runFormPost
         , dbParamsFormResult   = id
         , dbParamsFormIdent    = def
         }
@@ -309,7 +309,7 @@ postAdminUserR uuid = do
               campusHandler _ = mzero
             campusResult <- runMaybeT . handle campusHandler $ do
                 (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
-                void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
+                void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
             case campusResult of
               Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
               _other
@@ -475,7 +475,7 @@ postUserPasswordR cID = do
 
   formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
     newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
-    liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
+    liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
     tell . pure =<< messageI Success MsgPasswordChangedSuccess
 
   siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $
@@ -545,7 +545,7 @@ functionInvitationConfig = InvitationConfig{..}
       MsgRenderer mr <- getMsgRenderer
       return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
     invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
-      itAuthority <- liftHandlerT requireAuthId
+      itAuthority <- liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBUserFunctionDeadline
           itAddAuth = Nothing
           itStartsAt = Nothing

src/Handler/Utils.hs

@@ -2,7 +2,7 @@ module Handler.Utils
   ( module Handler.Utils
   ) where
 
-import Import
+import Import hiding (link)
 
 import qualified Data.Text.Encoding as T
 import Data.Map ((!))
@@ -38,7 +38,7 @@ sendThisFile File{..}
   | otherwise = sendResponseStatus noContent204 ()
 
 -- | Serve a single file, identified through a given DB query
-serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
+serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
 serveOneFile source = do
   results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
   case results of
@@ -51,7 +51,7 @@ serveOneFile source = do
 -- | Serve one file directly or a zip-archive of files, identified through a given DB query
 --
 -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
-serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
+serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
 serveSomeFiles archiveName source = do
   results <- runDB . runConduit $ source .| peekN 2
 
@@ -69,7 +69,7 @@ serveSomeFiles archiveName source = do
 -- | Serve any number of files as a zip-archive of files, identified through a given DB query
 --
 -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
-serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
+serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
 serveZipArchive archiveName source = do
   results <- runDB . runConduit $ source .| peekN 2
 
@@ -122,7 +122,7 @@ warnTermDays tid timeNames = do
 
 
 -- | return a value only if the current user ist authorized for a given route
-guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
+guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h
                       , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
   => Route UniWorX -> a -> m (ReaderT SqlBackend h) a
 guardAuthorizedFor link val =
@@ -138,7 +138,7 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
 
 studyFeaturesWidget :: StudyFeaturesId -> Widget
 studyFeaturesWidget featId = do
-  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
+  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
   [whamlet|
     $newline never
     _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}

src/Handler/Utils/Communication.hs

@@ -71,7 +71,7 @@ instance RenderMessage UniWorX RecipientCategory where
 data CommunicationRoute = CommunicationRoute
   { crRecipients    :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
   , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
-  , crJobs          :: Communication -> Source (YesodDB UniWorX) Job
+  , crJobs          :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
   , crHeading       :: SomeMessage UniWorX
   , crUltDest       :: SomeRoute UniWorX
   }
@@ -150,9 +150,9 @@ commR CommunicationRoute{..} =  do
                    -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
                    -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
                    -> Widget
-          miLayout liveliness state cellWdgts _delButtons addWdgts = do
+          miLayout liveliness cState cellWdgts _delButtons addWdgts = do
             checkedIdentBase <- newIdent
-            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state
+            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
                 checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
                 hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
                 categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
@@ -165,12 +165,15 @@ commR CommunicationRoute{..} =  do
           postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
           postProcess = Set.fromList . map fst . filter snd . Map.elems
 
+  recipientsListMsg <- messageI Info MsgCommRecipientsList
+
   ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
     <$> recipientAForm
+    <*  aformMessage recipientsListMsg
     <*> aopt textField (fslI  MsgCommSubject)     Nothing
-    <*> areq htmlField (fslpI MsgCommBody "Html") Nothing
+    <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing
   formResult commRes $ \comm -> do
-    runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
+    runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
     addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
     redirect crUltDest
 
@@ -183,4 +186,3 @@ commR CommunicationRoute{..} =  do
   siteLayoutMsg crHeading $ do
     setTitleI crHeading
     formWdgt
-    $(i18nWidgetFile "html-input")

src/Handler/Utils/ContentDisposition.hs

@@ -8,7 +8,7 @@ import Import
 -- | Check whether the user's preference for files is inline-viewing or downloading
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
 downloadFiles = do
-  mauth <- liftHandlerT maybeAuth
+  mauth <- liftHandler maybeAuth
   case mauth of
     Just (Entity _ User{..}) -> return userDownloadFiles
     Nothing -> do

src/Handler/Utils/Csv.hs

@@ -1,17 +1,16 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Csv
-  ( typeCsv, extensionCsv
+  ( decodeCsv
-  , decodeCsv
   , encodeCsv
+  , encodeDefaultOrderedCsv
   , respondCsv, respondCsvDB
+  , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB
   , fileSourceCsv
   , CsvParseError(..)
   , ToNamedRecord(..), FromNamedRecord(..)
   , DefaultOrdered(..)
   , ToField(..), FromField(..)
-  , CsvRendered(..)
-  , toCsvRendered
   ) where
 
 import Import hiding (Header, mapM_)
@@ -37,19 +36,7 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Attoparsec.ByteString.Lazy as A
 
 
-deriving instance Typeable CsvParseError
+decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
-instance Exception CsvParseError
-
-
-typeCsv, typeCsv' :: ContentType
-typeCsv = simpleContentType typeCsv'
-typeCsv' = "text/csv; charset=UTF-8; header=present"
-
-extensionCsv :: Extension
-extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
-
-
-decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv
 decodeCsv = transPipe throwExceptT $ do
   testBuffer <- accumTestBuffer LBS.empty
   mapM_ leftover $ LBS.toChunks testBuffer
@@ -111,47 +98,67 @@ decodeCsv = transPipe throwExceptT $ do
       
 
 encodeCsv :: ( ToNamedRecord csv
-             , DefaultOrdered csv
              , Monad m
              )
-          => Conduit csv m ByteString
+          => Header
+          -> ConduitT csv ByteString m ()
 -- ^ Encode a stream of records
 --
 -- Currently not streaming
-encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy
+encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy
+
+encodeDefaultOrderedCsv :: forall csv m.
+                           ( ToNamedRecord csv
+                           , DefaultOrdered csv
+                           , Monad m
+                           )
+                        => ConduitT csv ByteString m ()
+encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv)
 
   
-respondCsv :: ( ToNamedRecord csv
+respondCsv :: ToNamedRecord csv
-              , DefaultOrdered csv
+           => Header
-              )
+           -> ConduitT () csv (HandlerFor site) ()
-           => Source (HandlerT site IO) csv
+           -> HandlerFor site TypedContent
-           -> HandlerT site IO TypedContent
+respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
-respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
+
+respondDefaultOrderedCsv :: forall csv site.
+                            ( ToNamedRecord csv
+                            , DefaultOrdered csv
+                            )
+                         => ConduitT () csv (HandlerFor site) ()
+                         -> HandlerFor site TypedContent
+respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
 
 respondCsvDB :: ( ToNamedRecord csv
-                , DefaultOrdered csv
                 , YesodPersistRunner site
                 )
-             => Source (YesodDB site) csv
+             => Header
-             -> HandlerT site IO TypedContent
+             -> ConduitT () csv (YesodDB site) ()
-respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
+             -> HandlerFor site TypedContent
+respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
+
+respondDefaultOrderedCsvDB :: forall csv site.
+                              ( ToNamedRecord csv
+                              , DefaultOrdered csv
+                              , YesodPersistRunner site
+                              )
+                           => ConduitT () csv (YesodDB site) ()
+                           -> HandlerFor site TypedContent
+respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv)
 
 fileSourceCsv :: ( FromNamedRecord csv
                  , MonadResource m
                  , MonadLogger m
+                 , MonadThrow m
                  )
               => FileInfo
-              -> Source m csv
+              -> ConduitT () csv m ()
 fileSourceCsv = (.| decodeCsv) . fileSource
 
 
-data CsvRendered = CsvRendered
-  { csvRenderedHeader :: Header
-  , csvRenderedData :: [NamedRecord]
-  } deriving (Eq, Read, Show, Generic, Typeable)
-
 instance ToWidget UniWorX CsvRendered where
-  toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered")
+  toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered")
     where
       csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row
                   | columnKey <- Vector.toList csvRenderedHeader
@@ -160,14 +167,3 @@ instance ToWidget UniWorX CsvRendered where
                 ]
 
       headers = decodeUtf8 <$> Vector.toList csvRenderedHeader
-
-toCsvRendered :: forall mono.
-                 ( ToNamedRecord (Element mono)
-                 , DefaultOrdered (Element mono)
-                 , MonoFoldable mono
-                 )
-              => mono -> CsvRendered
-toCsvRendered (otoList -> csvs) = CsvRendered{..}
-  where
-    csvRenderedHeader = headerOrder (error "not forced" :: Element mono)
-    csvRenderedData   = map toNamedRecord csvs

src/Handler/Utils/Database.hs

@@ -34,10 +34,10 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from
 
 
 -- | Sub-Query to retrieve StudyFeatures with their human-readable names
-studyFeaturesQuery :: E.Esqueleto query expr backend
+studyFeaturesQuery
-  => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
+  :: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
-  -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms)
+  -> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms)
-  -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms))
+  -> E.SqlQuery (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms))
 studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
   E.on $ terms    E.^. StudyTermsId    E.==. features E.^. StudyFeaturesField
   E.on $ degree   E.^. StudyDegreeId   E.==. features E.^. StudyFeaturesDegree

src/Handler/Utils/DateTime.hs

@@ -75,7 +75,7 @@ instance HasLocalTime UTCTime where
 instance HasLocalTime TimeOfDay where
   toLocalTime = LocalTime systemEpochDay
 
-formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
+formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text
 formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
 
 -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
@@ -92,12 +92,12 @@ formatTimeW s t = toWidget =<< formatTime s t
 formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
 formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
 
-getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
+getTimeLocale :: MonadHandler m => m TimeLocale
 getTimeLocale = getTimeLocale' <$> languages
 
 getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
 getDateTimeFormat sel = do
-  mauth <- liftHandlerT maybeAuth
+  mauth <- liftHandler maybeAuth
   UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
   let
     fmt

src/Handler/Utils/Delete.hs

@@ -29,12 +29,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
 import qualified Database.Esqueleto.Internal.Language as E (From)
 
 
-data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
+data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From tables) => DeleteRoute
   { drRecords :: Set (Key record) -- ^ Records to be deleted
   , drGetInfo :: tables -> E.SqlQuery infoExpr -- ^ SQL-Query to get necessary information to render identifing information about records to the user (`drRenderRecord`, `drRecordConfirmString`); @tables@ is an arbitrary join, see `E.from`; @infoExpr@ gets converted to @info@ by esqueleto
   , drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically
-  , drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
+  , drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
-  , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
+  , drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
   , drCaption
   , drSuccessMessage :: SomeMessage UniWorX
   , drAbort
@@ -98,7 +98,7 @@ getDeleteR DeleteRoute{..} = do
 
   (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
 
-  Just targetRoute <- getCurrentRoute
+  targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
   let deleteForm = wrapForm deleteFormWdgt def
         { formAction = Just $ SomeRoute targetRoute
         , formEncoding = deleteFormEnctype

src/Handler/Utils/Exam.hs

@@ -2,6 +2,7 @@ module Handler.Utils.Exam
   ( fetchExamAux
   , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
   , examBonus, examBonusPossible, examBonusAchieved
+  , examResultBonus, examGrade
   ) where
 
 import Import.NoFoundation
@@ -16,6 +17,8 @@ import qualified Data.Conduit.List as C
 
 import qualified Data.Map as Map
 
+import Data.Fixed (Fixed(..))
+
 
 fetchExamAux :: ( SqlBackendCanRead backend
                 , E.SqlSelect b a
@@ -75,9 +78,86 @@ examBonus (Entity eId Exam{..}) = runConduit $
         )
       return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
     accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
-      Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub
+      flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
    in rawData .| accum
 
-examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary
+examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary
-examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap
+examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
-examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap
+examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
+
+
+examResultBonus :: ExamBonusRule
+                -> SheetGradeSummary -- ^ `examBonusPossible`
+                -> SheetGradeSummary -- ^ `examBonusAchieved`
+                -> Points
+examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
+  ExamBonusManual{}
+    -> 0
+  ExamBonusPoints{..}
+    -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
+  where
+    bonusProp :: Rational
+    bonusProp
+      | possible <= 0 = 1
+      | otherwise = achieved / possible
+      where
+        achieved = toRational (getSum $ achievedPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
+        possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
+        
+        scalePasses :: Integer -> Rational
+        -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
+        scalePasses passes
+          | passesPossible <= 0 = 0
+          | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
+          where
+            passesPossible = getSum $ numSheetsPasses bonusPossible
+            pointsPossible = getSum $ sumSheetsPoints bonusPossible
+
+    roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a
+    -- ^ 'round-to-nearest' whole multiple
+    roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw)
+      = MkFixed . (* mult') $
+          let (whole, frac) = raw `divMod'` mult
+           in if | abs frac < abs (mult / 2)
+                   -> whole
+                 | raw >= 0
+                   -> succ whole
+                 | otherwise
+                   -> pred whole
+ 
+examGrade :: ( MonoFoldable mono
+             , Element mono ~ ExamResultPoints
+             )
+          => Exam
+          -> Maybe Points -- ^ Bonus
+          -> mono -- ^ `ExamPartResult`s
+          -> Maybe ExamResultGrade
+examGrade Exam{..} mBonus (otoList -> results)
+  = traverse pointsToGrade achievedPoints'
+  where
+    achievedPoints' :: ExamResultPoints
+    achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results
+
+    withBonus :: Points -> Points
+    withBonus ps
+      | Just bonusRule <- examBonusRule
+      = if
+          |    maybe True not (bonusRule ^? _bonusOnlyPassed)
+            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
+            -> maybe id (+) mBonus ps
+          | otherwise
+            -> ps
+      | otherwise
+      = ps
+    
+    pointsToGrade :: Points -> Maybe ExamGrade
+    pointsToGrade ps = examGradingRule <&> \case
+      ExamGradingKey{..}
+        -> gradeFromKey examGradingKey
+      where
+        gradeFromKey :: [Points] -> ExamGrade
+        gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
+          where
+            lowerBounds :: [(ExamGrade, Points)]
+            lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
+        

src/Handler/Utils/Form.hs

@@ -214,7 +214,7 @@ optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' min
 
 
 multiAction :: forall action a.
-               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
+               ( RenderMessage UniWorX action, PathPiece action, Ord action )
             => Map action (AForm Handler a)
             -> FieldSettings UniWorX
             -> Maybe action
@@ -235,22 +235,22 @@ multiAction acts fs@FieldSettings{..} defAction csrf = do
 
   return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
 
-multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
+             => Map action (AForm Handler a)
              -> FieldSettings UniWorX
              -> Maybe action
              -> AForm Handler a
 multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
 
-multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              => Map action (AForm Handler a)
              -> FieldSettings UniWorX
              -> Maybe action
              -> WForm Handler (FormResult a)
 multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
 
-multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
+             => Map action (AForm Handler a)
              -> FieldSettings UniWorX
              -> Maybe action
              -> (Html -> MForm Handler (FormResult a, Widget))
@@ -279,7 +279,7 @@ routeField :: ( Monad m
 routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
 
 -- | Variant that simply removes leading and trailing white space
-htmlField' :: Field (HandlerT UniWorX IO) Html
+htmlField' :: Field Handler Html
 htmlField' = htmlField
   { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
   }
@@ -444,9 +444,11 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
 
     specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
     specificFileForm = wFormToAForm $ do
-      Just currentRoute <- getCurrentRoute
+      currentRoute' <- getCurrentRoute
       let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
-          miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
+          miButtonAction frag = do
+            currentRoute <- currentRoute'
+            return . SomeRoute $ currentRoute :#: frag
       miIdent <- ("specific-files--" <>) <$> newIdent
       postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
       where
@@ -518,7 +520,7 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
         )
       ]
 
-data ExamBonusRule' = ExamNoBonus'
+data ExamBonusRule' = ExamBonusManual'
                     | ExamBonusPoints'
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ExamBonusRule'
@@ -529,7 +531,7 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id
 
 classifyBonusRule :: ExamBonusRule -> ExamBonusRule'
 classifyBonusRule = \case
-  ExamNoBonus       -> ExamNoBonus'
+  ExamBonusManual{} -> ExamBonusManual'
   ExamBonusPoints{} -> ExamBonusPoints'
 
 examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
@@ -537,18 +539,19 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify
   where
     actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
     actions = Map.fromList
-      [ ( ExamNoBonus'
+      [ ( ExamBonusManual'
-        , pure ExamNoBonus
+        , ExamBonusManual
+            <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
         )
       , ( ExamBonusPoints'
         , ExamBonusPoints
-            <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev)
+            <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev)
             <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
+            <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev)
         )
       ]
 
-data ExamOccurrenceRule' = ExamRoomManual'
+data ExamOccurrenceRule' = ExamRoomSurname'
-                         | ExamRoomSurname'
                          | ExamRoomMatriculation'
                          | ExamRoomRandom'
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -560,7 +563,6 @@ embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id
 
 classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule'
 classifyExamOccurrenceRule = \case
-  ExamRoomManual        -> ExamRoomManual'
   ExamRoomSurname       -> ExamRoomSurname'
   ExamRoomMatriculation -> ExamRoomMatriculation'
   ExamRoomRandom        -> ExamRoomRandom'
@@ -569,13 +571,11 @@ examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurren
 examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule
   where
     reverseClassify = \case
-      ExamRoomManual'        -> ExamRoomManual
       ExamRoomSurname'       -> ExamRoomSurname
       ExamRoomMatriculation' -> ExamRoomMatriculation
       ExamRoomRandom'        -> ExamRoomRandom
 
-data ExamGradingRule' = ExamGradingManual'
+data ExamGradingRule' = ExamGradingKey'
-                      | ExamGradingKey'
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ExamGradingRule'
 instance Finite ExamGradingRule'
@@ -585,7 +585,6 @@ embedRenderMessage ''UniWorX ''ExamGradingRule' id
 
 classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule'
 classifyExamGradingRule = \case
-  ExamGradingManual -> ExamGradingManual'
   ExamGradingKey{}  -> ExamGradingKey'
 
 examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule
@@ -593,10 +592,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
   where
     actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule)
     actions = Map.fromList
-      [ ( ExamGradingManual'
+      [ ( ExamGradingKey'
-        , pure ExamGradingManual
-        )
-      , ( ExamGradingKey'
         , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev)
         )
       ]
@@ -659,7 +655,7 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
       | otherwise
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
-specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
+specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ())
 specificFileField UploadSpecificFile{..} = Field{..}
   where
     fieldEnctype = Multipart
@@ -677,7 +673,7 @@ specificFileField UploadSpecificFile{..} = Field{..}
 
 zipFileField :: Bool -- ^ Unpack zips?
              -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
-             -> Field Handler (Source Handler File)
+             -> Field Handler (ConduitT () File Handler ())
 zipFileField doUnpack permittedExtensions = Field{..}
   where
     fieldEnctype = Multipart
@@ -696,7 +692,7 @@ zipFileField doUnpack permittedExtensions = Field{..}
 
 fileUploadForm :: Bool -- ^ Required?
                -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
-               -> UploadMode -> AForm Handler (Maybe (Source Handler File))
+               -> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ()))
 fileUploadForm isReq mkFs = \case
   NoUpload
     -> pure Nothing
@@ -705,21 +701,21 @@ fileUploadForm isReq mkFs = \case
   UploadSpecific{..}
     -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
   where
-    specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
+    specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ()))
     specificFileForm spec@UploadSpecificFile{..}
       = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
 
-    mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
+    mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ())
     mergeFileSources (catMaybes -> sources) = case sources of
       [] -> Nothing
       fs -> Just $ sequence_ fs
 
-multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField`
+multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField`
-                -> Field Handler (Source Handler (Either FileId File))
+                -> Field Handler (ConduitT () (Either FileId File) Handler ())
 multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
 
 multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-               -> Field Handler (Source Handler (Either FileId File))
+               -> Field Handler (ConduitT () (Either FileId File) Handler ())
 multiFileField permittedFiles' = Field{..}
   where
     fieldEnctype = Multipart
@@ -735,7 +731,7 @@ multiFileField permittedFiles' = Field{..}
         .| C.filter (`elem` pVals)
         .| C.map Left
       let
-        handleFile :: FileInfo -> Source Handler File
+        handleFile :: FileInfo -> ConduitT () File Handler ()
         handleFile
           | doUnpack  = sourceFiles
           | otherwise = yieldM . acceptFile
@@ -899,7 +895,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel
 
 
 langField :: Bool -- ^ Only allow values from `appLanguages`
-          -> Field (HandlerT UniWorX IO) Lang
+          -> Field Handler Lang
 langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts
   where langCheck (T.splitOn "-" -> lParts)
           = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
@@ -922,7 +918,7 @@ jsonField hide = Field{..}
     fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v)
     fieldParse [] [] = return $ Right Nothing
     fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
-    fieldView theId name attrs val isReq = liftWidgetT [whamlet|
+    fieldView theId name attrs val isReq = liftWidget [whamlet|
       <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
     |]
     fieldEnctype = UrlEncoded
@@ -1019,7 +1015,7 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site
                           , PersistQueryRead backend
-                          , HasCryptoUUID (Key a) (HandlerT site IO)
+                          , HasCryptoUUID (Key a) (HandlerFor site)
                           , RenderMessage site msg
                           , YesodPersistBackend site ~ backend
                           , PersistRecordBackend a backend
@@ -1027,7 +1023,7 @@ optionsPersistCryptoId :: forall site backend a msg.
                        => [Filter a]
                        -> [SelectOpt a]
                        -> (a -> msg)
-                       -> HandlerT site IO (OptionList (Entity a))
+                       -> HandlerFor site (OptionList (Entity a))
 optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
   mr <- getMessageRender
   pairs <- runDB $ selectList filts ords
@@ -1044,7 +1040,7 @@ examOccurrenceField :: ( MonadHandler m
                     => ExamId
                     -> Field m ExamOccurrenceId
 examOccurrenceField eid
-  = hoistField liftHandlerT . selectField . (fmap $ fmap entityKey)
+  = hoistField liftHandler . selectField . (fmap $ fmap entityKey)
     $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
 
 
@@ -1080,7 +1076,7 @@ userMatriculationField = Field{..}
     fieldParse ts _ = runExceptT . fmap Just $ do
       let ts' = concatMap (Text.splitOn ",") ts
       forM ts' $ \matr -> do
-        dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do
+        dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do
           E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr)
           return user
         case dbRes of
@@ -1114,7 +1110,7 @@ multiUserField onlySuggested suggestions = Field{..}
           rEmails <- case lookupExpr of
             Nothing -> return []
             Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
-              dbRes <- liftHandlerT . runDB . E.select $ do
+              dbRes <- liftHandler . runDB . E.select $ do
                 user <- lookupExpr'
                 E.where_ $ user E.^. UserId E.==. E.val uid
                 return $ user E.^. UserEmail
@@ -1131,7 +1127,7 @@ multiUserField onlySuggested suggestions = Field{..}
       |]
 
       whenIsJust suggestions $ \suggestions' -> do
-        suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
+        suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do
           user <- suggestions'
           return $ user E.^. UserEmail
         [whamlet|
@@ -1147,14 +1143,14 @@ multiUserField onlySuggested suggestions = Field{..}
       fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
         Nothing -> return $ Left email
         Just lookupExpr' -> do
-            dbRes <- liftHandlerT . runDB . E.select $ do
+            dbRes <- liftHandler . runDB . E.select $ do
               user <- lookupExpr'
               E.where_ $ user E.^. UserEmail E.==. E.val email
               return $ user E.^. UserId
             case dbRes of
               [] -> return $ Left email
               [E.Value uid] -> return $ Right uid
-              _other -> fail "Ambiguous e-mail addr"
+              _other -> throwE $ SomeMessage ("Ambiguous e-mail addr" :: Text)
 
 examResultField :: forall m res.
                    ( MonadHandler m
@@ -1195,11 +1191,11 @@ examGradeField :: forall m.
                   , HandlerSite m ~ UniWorX
                   )
                => Field m ExamGrade
-examGradeField = hoistField liftHandlerT $ selectField optionsFinite
+examGradeField = hoistField liftHandler $ selectField optionsFinite
 
 examPassedField :: forall m.
                    ( MonadHandler m
                    , HandlerSite m ~ UniWorX
                    )
                 => Field m ExamPassed
-examPassedField = hoistField liftHandlerT $ selectField optionsFinite
+examPassedField = hoistField liftHandler $ selectField optionsFinite

src/Handler/Utils/Form/MassInput.hs

@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Handler.Utils.Form.MassInput
   ( MassInput(..), MassInputLayout
@@ -271,7 +271,7 @@ massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadLogger handler
+           , MonadThrow handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX
@@ -414,7 +414,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
 
   MsgRenderer mr <- getMsgRenderer
 
-  whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
+  whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandler $ do
     PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
     ur <- getUrlRenderParams
 
@@ -459,7 +459,7 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas
 -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
 massInputList :: forall handler cellResult ident.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                 , MonadLogger handler
+                 , MonadThrow handler
                  , PathPiece ident
                  )
               => Field handler cellResult
@@ -488,7 +488,7 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m
 
 massInputListA :: forall handler cellResult ident.
                   ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                  , MonadLogger handler
+                  , MonadThrow handler
                   , PathPiece ident
                   )
                => Field handler cellResult
@@ -505,7 +505,7 @@ massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired
 -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
 massInputAccum :: forall handler cellData ident.
                   ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                  , MonadLogger handler
+                  , MonadThrow handler
                   , ToJSON cellData, FromJSON cellData
                   , PathPiece ident
                   )
@@ -544,7 +544,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
 
 massInputAccumA :: forall handler cellData ident.
                   ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                  , MonadLogger handler
+                  , MonadThrow handler
                   , ToJSON cellData, FromJSON cellData
                   , PathPiece ident
                   )
@@ -562,7 +562,7 @@ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq
 
 massInputAccumW :: forall handler cellData ident.
                   ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                  , MonadLogger handler
+                  , MonadThrow handler
                   , ToJSON cellData, FromJSON cellData
                   , PathPiece ident
                   )
@@ -582,7 +582,7 @@ massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq
 -- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added
 massInputAccumEdit :: forall handler cellData ident.
                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                      , MonadLogger handler
+                      , MonadThrow handler
                       , ToJSON cellData, FromJSON cellData
                       , PathPiece ident
                       )
@@ -621,7 +621,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
 
 massInputAccumEditA :: forall handler cellData ident.
                        ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                       , MonadLogger handler
+                       , MonadThrow handler
                        , ToJSON cellData, FromJSON cellData
                        , PathPiece ident
                        )
@@ -639,7 +639,7 @@ massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings
 
 massInputAccumEditW :: forall handler cellData ident.
                        ( MonadHandler handler, HandlerSite handler ~ UniWorX
-                       , MonadLogger handler
+                       , MonadThrow handler
                        , ToJSON cellData, FromJSON cellData
                        , PathPiece ident
                        )
@@ -660,7 +660,7 @@ massInputA :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadLogger handler
+           , MonadThrow handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX
@@ -674,7 +674,7 @@ massInputW :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadLogger handler
+           , MonadThrow handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX

src/Handler/Utils/Form/Occurrences.hs

@@ -31,9 +31,10 @@ nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id
 
 
+{-# ANN occurrencesAForm ("HLint: ignore Use const" :: String) #-}
 occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences
 occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
-  Just cRoute <- getCurrentRoute
+  cRoute <- fromMaybe (error "occurrencesAForm called from 404-handler") <$> getCurrentRoute
 
   let
     scheduled :: AForm Handler (Set OccurrenceSchedule)

src/Handler/Utils/Invitations.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Handler.Utils.Invitations
   ( -- * Procedure
@@ -38,7 +39,7 @@ import qualified Data.Aeson as JSON
 import Data.Proxy (Proxy(..))
 import Data.Typeable
 
-import Database.Persist.Sql (SqlBackendCanWrite, SqlBackendCanRead)
+import Database.Persist.Sql (SqlBackendCanWrite)
 
 
 class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
@@ -169,11 +170,13 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju
 
 sinkInvitations :: forall junction m backend.
                    ( IsInvitableJunction junction
-                   , MonadHandler m, SqlBackendCanWrite backend
+                   , MonadHandler m
+                   , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
+                   , HasPersistBackend backend
                    , HandlerSite m ~ UniWorX
                    )
                 => InvitationConfig junction
-                -> Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
+                -> ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
 -- | Register invitations in the database and send them by email
 --
 -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
@@ -181,9 +184,10 @@ sinkInvitations :: forall junction m backend.
 -- (because the token-data may have changed)
 sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
   where
-    determineExists :: Conduit (Invitation' junction)
+    determineExists :: ConduitT (Invitation' junction)
-                               (ReaderT backend (WriterT (Set QueuedJobId) m))
+                                (Invitation' junction)
-                               (Invitation' junction)
+                                (ReaderT backend (WriterT (Set QueuedJobId) m))
+                                ()
     determineExists
       | is _Just (ephemeralInvitation @junction)
       = C.map id
@@ -203,10 +207,10 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
         decode invData
           = case fromJSON invData of
               JSON.Success dbData -> return dbData
-              JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
+              JSON.Error   str    -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
 
-    sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
+    sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
-    sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do
+    sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do
       C.mapM_ $ \(jInvitee, fid, dat) -> do
         app <- getYesod
         let mr = renderMessage app $ NonEmpty.toList appLanguages
@@ -214,15 +218,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
 
         fEnt <- Entity fid <$> get404 fid
 
-        jInviter <- liftHandlerT requireAuthId
+        jInviter <- liftHandler requireAuthId
-        route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
+        route <- mapReaderT liftHandler $ invitationRoute fEnt dat
-        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat
+        InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
         protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
         let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
         jwt <- encodeToken token
         jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
-        jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
+        jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
-        jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat)
+        jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
 
         when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation
                                                                        { invitationEmail = jInvitee
@@ -237,7 +241,10 @@ sinkInvitationsF :: forall junction mono m backend.
                     ( IsInvitableJunction junction
                     , MonoFoldable mono
                     , Element mono ~ Invitation' junction
-                    , MonadHandler m, SqlBackendCanWrite backend
+                    , MonadHandler m
+                    , MonadThrow m
+                    , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
+                    , HasPersistBackend backend
                     , HandlerSite m ~ UniWorX
                     )
                  => InvitationConfig junction
@@ -248,7 +255,10 @@ sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
 
 sinkInvitation :: forall junction m backend.
                   ( IsInvitableJunction junction
-                  , MonadHandler m, SqlBackendCanWrite backend
+                  , MonadHandler m
+                  , MonadThrow m
+                  , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
+                  , HasPersistBackend backend
                   , HandlerSite m ~ UniWorX
                   )
                => InvitationConfig junction
@@ -260,23 +270,29 @@ sinkInvitation cfg = sinkInvitationsF cfg . Identity
 
 sourceInvitations :: forall junction m backend.
                      ( IsInvitableJunction junction
-                     , MonadResource m, SqlBackendCanRead backend
+                     , MonadResource m
+                     , MonadThrow m
+                     , PersistRecordBackend Invitation backend
+                     , HasPersistBackend backend
                      )
                   => Key (InvitationFor junction)
-                  -> Source (ReaderT backend m) (UserEmail, InvitationDBData junction)
+                  -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
 sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
   where
     decode (Entity _ (Invitation{invitationEmail, invitationData}))
       = case fromJSON invitationData of
           JSON.Success dbData -> return (invitationEmail, dbData)
-          JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
+          JSON.Error   str    -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
 
 sourceInvitationsF :: forall junction map m backend.
                          ( IsInvitableJunction junction
                          , IsMap map
                          , ContainerKey map ~ UserEmail
                          , MapValue map ~ InvitationDBData junction
-                         , MonadResource m, SqlBackendCanRead backend
+                         , MonadResource m
+                         , MonadThrow m
+                         , PersistRecordBackend Invitation backend
+                         , HasPersistBackend backend
                          )
                    => Key (InvitationFor junction)
                    -> ReaderT backend m map 
@@ -291,15 +307,17 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (
 -- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId
 deleteInvitations :: forall junction m backend.
                      ( IsInvitableJunction junction
-                     , MonadIO m, SqlBackendCanWrite backend
+                     , MonadIO m
+                     , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
                      )
                   => Key (InvitationFor junction)
-                  -> Sink UserEmail (ReaderT backend m) ()
+                  -> ConduitT UserEmail Void (ReaderT backend m) ()
 deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k
   
 deleteInvitationsF :: forall junction m mono backend.
                       ( IsInvitableJunction junction
-                      , MonadIO m, SqlBackendCanWrite backend
+                      , MonadIO m
+                      , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
                       , MonoFoldable mono
                       , Element mono ~ UserEmail
                       )
@@ -312,7 +330,8 @@ deleteInvitationsF invitationFor (otoList -> emailList)
 
 deleteInvitation :: forall junction m backend.
                     ( IsInvitableJunction junction
-                    , MonadIO m, SqlBackendCanWrite backend
+                    , MonadIO m
+                    , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
                     )
                  => Key (InvitationFor junction)
                  -> UserEmail
@@ -344,10 +363,10 @@ invitationR' :: forall junction m.
              => InvitationConfig junction
              -> m Html
 -- | Generic handler for incoming invitations
-invitationR' InvitationConfig{..} = liftHandlerT $ do
+invitationR' InvitationConfig{..} = liftHandler $ do
   InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
   invitee <- requireAuthId
-  Just cRoute <- getCurrentRoute
+  cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
 
   (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
     fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
@@ -356,7 +375,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
         Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
         case fromJSON invitationData of
           JSON.Success dbData -> return dbData
-          JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
+          JSON.Error   str    -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str
       Just (cloneIso -> _DBData) -> return $ view _DBData ()
     let
       iData :: InvitationData junction

src/Handler/Utils/Mail.hs

@@ -19,11 +19,10 @@ import Control.Monad.Trans.State (StateT)
 
 
 addRecipientsDB :: ( MonadMail m
-                   , MonadHandler m
                    , HandlerSite m ~ UniWorX
                    ) => [Filter User] -> m ()
 -- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
-addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
+addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
   where
     addRecipient (Entity _ User{userEmail, userDisplayName}) = do
       let addr = Address (Just userDisplayName) $ CI.original userEmail
@@ -34,8 +33,8 @@ userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $
 
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
-             , MonadBaseControl IO m
+             , MonadThrow m
-             , MonadLogger m
+             , MonadUnliftIO m
              ) => UserId -> MailT m a -> m a
 userMailT uid mAct = do
   user@User
@@ -43,7 +42,7 @@ userMailT uid mAct = do
     , userDateTimeFormat
     , userDateFormat
     , userTimeFormat
-    } <- liftHandlerT . runDB $ getJust uid
+    } <- liftHandler . runDB $ getJust uid
   let
     ctx = MailContext
       { mcLanguages = userMailLanguages
@@ -57,14 +56,13 @@ userMailT uid mAct = do
     mAct
 
 addFileDB :: ( MonadMail m
-             , MonadHandler m
              , HandlerSite m ~ UniWorX
-             ) => FileId -> m MailObjectId
+             ) => FileId -> m (Maybe MailObjectId)
-addFileDB fId = do
+addFileDB fId = runMaybeT $ do
-  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId
-  addPart $ do
+  lift . addPart $ do
     _partType .= decodeUtf8 (mimeLookup fileName)
     _partEncoding .= Base64
     _partFilename .= Just fileName
     _partContent .= LBS.fromStrict fileContent
-    setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
+    setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId

src/Handler/Utils/Rating.hs

@@ -133,7 +133,7 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
 
 parseRating :: MonadThrow m => File -> m Rating'
 parseRating File{ fileContent = Just input, .. } = do
-  inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
+  inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input
   let
     (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
     (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
@@ -143,20 +143,20 @@ parseRating File{ fileContent = Just input, .. } = do
     rating = "Bewertung:"
   comment' <- case commentLines of
     (_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
-    _ -> throw RatingMissingSeparator
+    _ -> throwM RatingMissingSeparator
   let
     ratingComment
       | Text.null comment' = Nothing
       | otherwise = Just comment'
   ratingLine' <- case ratingLines' of
     [l] -> return l
-    _ -> throw RatingMultiple
+    _ -> throwM RatingMultiple
   let
     (_, ratingLine) = Text.breakOnEnd rating ratingLine'
     ratingStr = Text.unpack $ Text.strip ratingLine
   ratingPoints <- case () of
     _ | null ratingStr -> return Nothing
-      | otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr
+      | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr
   return Rating'{ ratingTime = Just fileModified, .. }
 parseRating _ = throwM RatingFileIsDirectory
 
@@ -166,7 +166,7 @@ type SubmissionContent = Either File (SubmissionId, Rating')
 extractRatings :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
-                  ) => Conduit File m SubmissionContent
+                  ) => ConduitT File SubmissionContent m ()
 extractRatings = Conduit.mapM $ \f@File{..} -> do
   msId <- isRatingFile fileTitle
   case () of

src/Handler/Utils/Sheet.hs

@@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case
   SheetMarking  -> Nothing
 
 
-fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
+fetchSheetAux ::  ( E.SqlSelect b a
-                  , E.SqlSelect b a
+                  , Typeable a, MonadHandler m
-                  , Typeable a, MonadHandler m, IsPersistBackend backend
-                  , PersistQueryRead backend, PersistUniqueRead backend
                   )
   =>  (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
-      -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
+      -> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a
 fetchSheetAux prj tid ssh csh shn =
     let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
     in  cachedBy cachId $ do

src/Handler/Utils/Submission.hs

@@ -252,7 +252,7 @@ planSubmissions sid restriction = do
     unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
 
 
-submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) ()
 submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
 
 submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
@@ -285,7 +285,7 @@ submissionMultiArchive (Set.toList -> ids) = do
   setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip)
   (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do
     let
-      fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File
+      fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) ()
       fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
         cID <- encrypt submissionID
 
@@ -301,7 +301,7 @@ submissionMultiArchive (Set.toList -> ids) = do
             | otherwise              =                                                                 submissionDirectory
 
           fileEntitySource = do
-            submissionFileSource submissionID =$= Conduit.map entityVal
+            submissionFileSource submissionID .| Conduit.map entityVal
             yieldM (ratingFile cID rating)
 
           withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
@@ -316,9 +316,9 @@ submissionMultiArchive (Set.toList -> ids) = do
           , fileContent = Nothing
           }
 
-        fileEntitySource =$= mapC withinDirectory
+        fileEntitySource .| mapC withinDirectory
 
-    mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
+    mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder
 
 
 
@@ -331,9 +331,12 @@ data SubmissionSinkState = SubmissionSinkState
   , sinkFilenames :: Set FilePath
   } deriving (Show, Eq, Generic, Typeable)
 
+instance Semigroup SubmissionSinkState where
+  (<>) = mappenddefault
+
 instance Monoid SubmissionSinkState where
   mempty = memptydefault
-  mappend = mappenddefault
+  mappend = (<>)
 
 filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
 -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
@@ -351,15 +354,13 @@ filterSubmission = do
 extractRatings :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
-                  , MonadLogger m
                   ) => ConduitM File SubmissionContent m (Set FilePath)
 extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
 
 extractRatingsMsg :: ( MonadHandler m
                      , HandlerSite m ~ UniWorX
                      , MonadCatch m
-                     , MonadLogger m
+                     ) => ConduitT File SubmissionContent m ()
-                     ) => Conduit File m SubmissionContent
 extractRatingsMsg = do
   ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
   let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
@@ -385,7 +386,7 @@ msgSubmissionErrors = flip catches
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
-               -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId
+               -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId
 -- ^ Replace the currently saved files for the given submission (either
 --   corrected files or original ones, depending on arguments) with the supplied
 --   'SubmissionContent'.
@@ -420,7 +421,7 @@ sinkSubmission userId mExists isUpdate = do
   where
     tellSt = modify . mappend
 
-    guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent
+    guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m ()
     guardFileTitles SubmissionMode{..}
       | Just UploadAny{..} <- submissionModeUser
       , not isUpdate
@@ -435,7 +436,7 @@ sinkSubmission userId mExists isUpdate = do
       | otherwise = Conduit.map id
 
     sinkSubmission' :: SubmissionId
-                    -> Sink SubmissionContent (YesodJobDB UniWorX) ()
+                    -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@@ -628,7 +629,7 @@ sinkSubmission userId mExists isUpdate = do
 
 sinkMultiSubmission :: UserId
                     -> Bool {-^ Are these corrections -}
-                    -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId)
+                    -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId)
 
 -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
 --
@@ -666,7 +667,7 @@ sinkMultiSubmission userId isUpdate = do
     v@(Right (sId, _)) -> do
       cID <- encrypt sId
       $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
-      lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
+      lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ])
     (Left f@File{..})  -> do
       let
         acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
@@ -678,7 +679,7 @@ sinkMultiSubmission userId isUpdate = do
                   sId <- decrypt (cID :: CryptoFileNameSubmission)
                   Just sId <$ get404 sId
               | otherwise = return Nothing
-          msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
+          msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ])
           return (msId, fp)
       (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
       case msId of
@@ -687,8 +688,8 @@ sinkMultiSubmission userId isUpdate = do
         Just sId -> do
           $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
           cID <- encrypt sId
-          handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
+          lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
-            lift . feed sId $ Left f{ fileTitle = fileTitle' }
+            feed sId $ Left f{ fileTitle = fileTitle' }
   when (not $ null ignoredFiles) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

src/Handler/Utils/Table.hs

@@ -1,100 +1,7 @@
 module Handler.Utils.Table
   ( module Handler.Utils.Table
   ) where
--- General Utilities for Tables
-
-import Import
-
-import Control.Monad.Except
-
-import Text.Blaze as B
-
-import Colonnade
-import Yesod.Colonnade as Yesod
-
-import Data.List ((!!))
-import Data.Either
   
 import Handler.Utils.Table.Pagination as Handler.Utils.Table
 import Handler.Utils.Table.Columns as Handler.Utils.Table
 import Handler.Utils.Table.Cells as Handler.Utils.Table
-
-
--- Table design
-{-# DEPRECATED tableDefault, tableSortable "Use dbTable" #-}
-tableDefault :: Attribute
-tableDefault = customAttribute "class" "table table-striped table-hover"
-
-tableSortable :: Attribute
-tableSortable = customAttribute "class" "js-sortable"
-
--- Colonnade Tools
-{-# DEPRECATED numberColonnade, pairColonnade "Use dbTable" #-}
-numberColonnade :: (IsString c) => Colonnade Headed Int c
-numberColonnade = headed "Nr" (fromString.show)
-
-pairColonnade :: (Functor h) =>  Colonnade h a c -> Colonnade h b c ->  Colonnade h (a,b) c
-pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
-
-
--- Table Modification
-{-# DEPRECATED encodeHeadedWidgetTableNumbered, headedRowSelector "Use dbTable" #-}
-encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
-encodeHeadedWidgetTableNumbered attrs colo tdata =
-    encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
-  where
-    numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
-    numberCol = headed "Nr" (fromString.show.fst)
-
-headedRowSelector :: ( PathPiece b
-                     , Eq b
-                     )
-                  => (a -> Handler b)
-                  -> (b -> Handler c)
-                  -> Attribute
-                  -> Colonnade Headed a (Cell UniWorX)
-                  -> [a]
-                  -> MForm Handler (FormResult [c], Widget)
-headedRowSelector toExternal fromExternal attrs colonnade tdata = do
-  externalIds <- mapM (lift . toExternal) tdata
-
-  let
-    checkbox extId = Field{..}
-      where
-        fieldEnctype = UrlEncoded
-        
-        fieldParse [] _ = return $ Right Nothing
-        fieldParse optlist _ = runExceptT $ do
-          extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
-          case () of
-            _ | extId `elem` extIds
-                -> Just <$> lift (fromExternal extId)
-              | otherwise
-                -> return Nothing
-
-        fieldView theId name attributes val _ =
-          -- TODO: move this to a *.hamlet file
-          [whamlet|
-            <label style="display: block">
-              <input ##{theId} type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
-          |]
-
-  selectionIdent <- newFormIdent
-
-  (selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \ident -> mopt (checkbox ident) ("" { fsName = Just selectionIdent }) Nothing
-
-  let
-    selColonnade :: Colonnade Headed Int (Cell UniWorX)
-    selColonnade = headed "Markiert" $ Yesod.cell . fvInput . (selectionBoxes !!)
-
-    collectResult :: [FormResult a] -> FormResult [a]
-    collectResult [] = FormSuccess []
-    collectResult (FormFailure errs : _) = FormFailure errs
-    collectResult (FormMissing:rs) = collectResult rs
-    collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
-
-  return ( catMaybes <$> collectResult selectionResults
-         , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
-         )
-
-

src/Handler/Utils/Table/Cells.hs

@@ -1,8 +1,6 @@
 module Handler.Utils.Table.Cells where
 
-import Import
+import Import hiding (link)
-
-import qualified Control.Monad.Trans.RWS.Lazy
 
 import Data.CaseInsensitive (CI)
 -- import qualified Data.CaseInsensitive as CI
@@ -28,37 +26,17 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
 -- Some basic cells are defined in Handler.Utils.Table.Pagination
 -- such as: i18nCell, cellTooltip, anchorCell for links, etc.
 
-----------------
--- Cell transformation
-
--- | Add cell attributes
-addCellAttrs :: [(Text, Text)]
-  -> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
-                              (Maybe (Env, FileEnv), UniWorX, [Lang])
-                              Enctype
-                              Ints
-                              (HandlerT UniWorX IO))
-                           x
-  -> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
-                              (Maybe (Env, FileEnv), UniWorX, [Lang])
-                              Enctype
-                              Ints
-                              (HandlerT UniWorX IO))
-                           x
-addCellAttrs newAttrs fcell = fcell { formCellAttrs = newAttrs <> formCellAttrs fcell } -- Isn't there already a lens for that?
-
-
 ----------------
 -- Special cells
 
 -- | Display a breakable space
-spacerCell :: (IsDBTable m a) => DBCell m a
+spacerCell :: IsDBTable m a => DBCell m a
 spacerCell = cell [whamlet|&emsp;|]
 
-tellCell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a
+tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
 tellCell = flip mappend . writerCell . tell
 
-cellTell :: (Monoid a, IsDBTable m a) => DBCell m a -> a -> DBCell m a
+cellTell :: IsDBTable m a => DBCell m a -> a -> DBCell m a
 cellTell = flip tellCell
 
 indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
@@ -67,7 +45,7 @@ indicatorCell = writerCell . tell $ Any True
 writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
-maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
+maybeCell :: IsDBTable m a => Maybe a -> (a -> DBCell m a) -> DBCell m a
 maybeCell = flip foldMap
 
 htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
@@ -81,12 +59,12 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
 sqlCell act = mempty & cellContents .~ lift act
 
 -- | Highlight table cells with warning: Is not yet implemented in frontend.
-markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
+markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
 markCell status condition normal x
-   | condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status)
+   | condition x = normal x & addCellClass (statusToUrgencyClass status)
    | otherwise   = normal x
 
-ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
+ifCell :: (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
 ifCell decision cTrue cFalse x
   | decision x = cTrue  x
   | otherwise  = cFalse x
@@ -105,22 +83,22 @@ msgCell = textCell . toMessage
 iconCell :: IsDBTable m a => Icon -> DBCell m a
 iconCell = cell . toWidget . icon
 
-addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
+addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
-addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
+addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)
 
-iconSpacerCell :: (IsDBTable m a) => DBCell m a
+iconSpacerCell :: IsDBTable m a => DBCell m a
 iconSpacerCell = mempty & addIconFixedWidth
 
 -- | Maybe display a tickmark/checkmark icon
-tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
+tickmarkCell :: IsDBTable m a => Bool -> DBCell m a
 tickmarkCell = cell . toWidget . hasTickmark
 
 -- | Maybe display an icon for tainted rows
-isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
+isBadCell :: IsDBTable m a => Bool -> DBCell m a
 isBadCell = cell . toWidget . isBad
 
 -- | Maybe display a exclamation icon
-isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
+isNewCell :: IsDBTable m a => Bool -> DBCell m a
 isNewCell = cell . toWidget . isNew
 
 -- | Maybe display comment icon linking a given URL or show nothing at all
@@ -129,11 +107,11 @@ commentCell Nothing     = mempty
 commentCell (Just link) = anchorCell link $ hasComment True
 
 -- | whether something is visible or hidden
-isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
+isVisibleCell :: IsDBTable m a => Bool -> DBCell m a
 isVisibleCell True  =  cell . toWidget $ isVisible True
 isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
   where
-    addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
+    addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
 
 -- | for simple file downloads
 fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
@@ -171,7 +149,7 @@ dateTimeCellVisible watershed t
     | otherwise     = cell timeStampWgt
   where
     timeStampWgt    = formatTimeW SelFormatDateTime t
-    addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
+    addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
 
 userCell :: IsDBTable m a => Text -> Text -> DBCell m a
 userCell displayName surname = cell $ nameWidget displayName surname
@@ -218,13 +196,13 @@ cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _s
 maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
 maybeDateTimeCell = maybe mempty dateTimeCell
 
-numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a
+numCell :: (IsDBTable m a, ToMessage b) => b -> DBCell m a
 numCell = textCell . toMessage
 
 propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a
 propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
 
-int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
+int64Cell :: IsDBTable m a => Int64-> DBCell m a
 int64Cell = numCell
 
 termCell :: IsDBTable m a => TermId -> DBCell m a
@@ -269,7 +247,7 @@ sheetCell crse shn =
   let tid = crse ^. _1
       ssh = crse ^. _2
       csh = crse ^. _3
-      link= CSheetR tid ssh csh shn SShowR
+      link = CSheetR tid ssh csh shn SShowR
   in anchorCell link $ toWgt shn
 
 submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a

src/Handler/Utils/Table/Columns.hs

@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module Handler.Utils.Table.Columns where
 
-import Import
+import Import hiding (link)
 
 -- import Data.CaseInsensitive (CI)
 -- import qualified Data.CaseInsensitive as CI
@@ -323,7 +325,7 @@ colApplicationId :: OpticColonnade CourseApplicationId
 colApplicationId resultId = Colonnade.singleton (fromSortable header) body
   where
     header = Sortable Nothing (i18nCell MsgCourseApplicationId)
-    body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
+    body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
 
 colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
 colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
@@ -813,7 +815,7 @@ anchorColonnadeM :: forall h r' m a url.
                     , IsDBTable m a
                     , HandlerSite m ~ UniWorX
                     )
-                 => (r' -> WidgetT UniWorX IO url)
+                 => (r' -> WidgetFor UniWorX url)
                  -> Colonnade h r' (DBCell m a)
                  -> Colonnade h r' (DBCell m a)
 anchorColonnadeM mkUrl = imapColonnade anchorColonnade'

src/Handler/Utils/Table/Pagination.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , dbFilterKey
@@ -17,6 +19,7 @@ module Handler.Utils.Table.Pagination
   , singletonFilter
   , DBParams(..)
   , cellAttrs, cellContents
+  , addCellClass
   , PagesizeLimit(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
@@ -50,6 +53,9 @@ import Utils
 import Utils.Lens
 
 import Import hiding (pi)
+
+import qualified Yesod.Form.Functions as Yesod
+  
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
@@ -111,6 +117,8 @@ import qualified Control.Monad.Catch as Catch
 
 import Data.Dynamic
 
+import qualified Data.Csv as Csv
+
 
 #if MIN_VERSION_base(4,11,0)
 type Monoid' = Monoid
@@ -513,17 +521,18 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
 
 
 data DBTCsvEncode r' k' csv = forall exportData.
-  ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+  ( ToNamedRecord csv, CsvColumnsExplained csv
   , DBTableKey k'
   , Typeable exportData
   ) => DBTCsvEncode
   { dbtCsvExportForm   :: AForm (YesodDB UniWorX) exportData
-  , dbtCsvDoEncode     :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv
+  , dbtCsvHeader       :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
+  , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
   , dbtCsvName         :: FilePath
   , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
   }
 data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
-  ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
+  ( FromNamedRecord csv, ToNamedRecord csv
   , DBTableKey k'
   , RedirectUrl UniWorX route
   , Typeable csv
@@ -532,10 +541,10 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
   , Exception csvException
   ) => DBTCsvDecode
   { dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
-  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> Source (YesodDB UniWorX) csvAction
+  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
   , dbtCsvClassifyAction :: csvAction -> csvActionClass
   , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
-  , dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route
+  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodDB UniWorX) route
   , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
   , dbtCsvRenderActionClass :: csvActionClass -> Widget
   , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
@@ -545,7 +554,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
-  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
+  , E.From t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
@@ -566,7 +575,8 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
 noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
 noCsvEncode = Nothing
 
-simpleCsvEncode :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+simpleCsvEncode :: forall fp r' k' csv.
+                   ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                    , DBTableKey k'
                    , Textual fp
                    )
@@ -576,9 +586,11 @@ simpleCsvEncode fName f = Just DBTCsvEncode
   , dbtCsvDoEncode     = \() -> C.map (f . view _2)
   , dbtCsvName         = unpack fName
   , dbtCsvNoExportData = Just id
+  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   }
 
-simpleCsvEncodeM :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+simpleCsvEncodeM :: forall fp r' k' csv.
+                    ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                     , DBTableKey k'
                     , Textual fp
                     )
@@ -588,6 +600,7 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
   , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
   , dbtCsvName         = unpack fName
   , dbtCsvNoExportData = Just id
+  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   }
 
 
@@ -615,14 +628,17 @@ cellAttrs = dbCell . _1
 cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
 cellContents = dbCell . _2
 
-instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
+addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
-  data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
+addCellClass = over cellAttrs . Yesod.addClass . toPathPiece
-  type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-  -- type DBResult' (WidgetT UniWorX IO) () = ()
 
-  data DBCell (HandlerT UniWorX IO) x = WidgetCell
+instance Monoid' x => IsDBTable (HandlerFor UniWorX) x where
+  data DBParams (HandlerFor UniWorX) x = DBParamsWidget
+  type DBResult (HandlerFor UniWorX) x = (x, Widget)
+  -- type DBResult' (WidgetFor UniWorX) () = ()
+
+  data DBCell (HandlerFor UniWorX) x = WidgetCell
     { wgtCellAttrs :: [(Text, Text)]
-    , wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
+    , wgtCellContents :: WriterT x (HandlerFor UniWorX) Widget
     }
 
   dbCell = iso
@@ -632,25 +648,25 @@ instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
-  runDBTable _ _ _ = liftHandlerT
+  runDBTable _ _ _ = liftHandler
 
-instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (HandlerFor UniWorX) x) where
   (WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
 
-instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
+instance Monoid' x => Monoid (DBCell (HandlerFor UniWorX) x) where
   mempty = WidgetCell mempty $ return mempty
   mappend = (<>)
 
-instance Default (DBParams (HandlerT UniWorX IO) x) where
+instance Default (DBParams (HandlerFor UniWorX) x) where
   def = DBParamsWidget
 
-instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
+instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
-  data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
+  data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
-  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
+  type DBResult (ReaderT SqlBackend (HandlerFor UniWorX)) x = (x, Widget)
 
-  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
+  data DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBCell
     { dbCellAttrs :: [(Text, Text)]
-    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
+    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerFor UniWorX)) Widget
     }
 
   dbCell = iso
@@ -659,17 +675,17 @@ instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x whe
 
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
-  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
+  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerFor UniWorX) ((), Widget) -> m (Widget)
-  runDBTable _ _ _ = mapReaderT liftHandlerT
+  runDBTable _ _ _ = mapReaderT liftHandler
 
-instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
   (DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
 
-instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
   mempty = DBCell mempty $ return mempty
   mappend = (<>)
 
-instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+instance Default (DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
   def = DBParamsDB
 
 data DBParamsFormIdent where
@@ -685,29 +701,29 @@ unDBParamsFormIdent DBTable{dbtIdent}  DBParamsFormTableIdent       = Just $ toP
 unDBParamsFormIdent _                 (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
 unDBParamsFormIdent _                  DBParamsFormNoIdent          = Nothing
 
-instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
+instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x where
-  data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
+  data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. DBParamsForm
     { dbParamsFormMethod     :: StdMethod
     , dbParamsFormAction     :: Maybe (SomeRoute UniWorX)
     , dbParamsFormAttrs      :: [(Text, Text)]
     , dbParamsFormSubmit     :: FormSubmitType
     , dbParamsFormAdditional :: Form a
-    , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
+    , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerFor UniWorX) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
     , dbParamsFormResult     :: Lens' x (FormResult a)
     , dbParamsFormIdent      :: DBParamsFormIdent
     }
-  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
+  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = (x, Widget)
-  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
+  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a) = (FormResult a, Enctype)
 
-  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. FormCell
+  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. FormCell
     { formCellAttrs :: [(Text, Text)]
-    , formCellContents :: WriterT x (MForm (HandlerT UniWorX IO)) (FormResult a, Widget)
+    , formCellContents :: WriterT x (MForm (HandlerFor UniWorX)) (FormResult a, Widget)
     , formCellLens :: Lens' x (FormResult a)
     }
 
   -- dbCell :: Iso'
-  --             (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) x)
+  --             (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
-  --             ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
+  --             ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerFor UniWorX)) Widget)
   dbCell = iso
     (\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
     (\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))
@@ -716,7 +732,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
   --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
-  -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
+  -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerFor UniWorX)) x -> PaginationInput -> [k'] -> (MForm (HandlerFor UniWorX)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
   runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
     = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
     . dbParamsFormEvaluate
@@ -734,19 +750,19 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
       adjResult _                  = FormFailure $ pure reasonTxt
     return $ over (_1 . dbParamsFormResult) adjResult result
 
-instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
   def = DBParamsForm
     { dbParamsFormMethod     = POST
     , dbParamsFormAction     = Nothing
     , dbParamsFormAttrs      = []
     , dbParamsFormSubmit     = FormSubmit
     , dbParamsFormAdditional = \_ -> return (pure (), mempty)
-    , dbParamsFormEvaluate   = liftHandlerT . runFormPost
+    , dbParamsFormEvaluate   = liftHandler . runFormPost
     , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
     , dbParamsFormIdent      = def
     }
 
-dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
+dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerFor UniWorX)) x -> DBParams (MForm (HandlerFor UniWorX)) x -> (Html -> MForm (HandlerFor UniWorX) (x, Widget)) -> (Html -> MForm (HandlerFor UniWorX) (x, Widget))
 dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
   let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
   ((res, fWidget), enctype) <- listen form
@@ -781,10 +797,10 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
     wIdent :: Text -> Text
     wIdent = toPathPiece . WithIdent dbtIdent
 
-instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
   (FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
 
-instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
   mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
   mappend = (<>)
 
@@ -839,7 +855,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
 
     (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
-          areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
+          areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
     return (filterRes', pagesizeRes')
 
   let
@@ -863,8 +879,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   mapM_ (addMessageI Warning) errs
 
-  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
+  currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
-  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
   let
     tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
     tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
@@ -964,15 +980,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     DBCsvExport{..}
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just exportData <- fromDynamic dbCsvExportData -> do
+        hdr <- dbtCsvHeader $ Just exportData
         let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName
         setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName
-        sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
+        sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
     DBCsvImport{..}
-      | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
+      | Just DBTCsvEncode{..} <- dbtCsvEncode
+      , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
                           , ..
                           } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
         let existing = Map.fromList $ zip currentKeys rows
-            sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k')
+            sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
             sourceDiff = do
               let
                 toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
@@ -1001,7 +1019,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
             importCsv = do
               let
-                dbtCsvComputeActions' :: Sink (DBCsvDiff r' csv k') (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
+                dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
                 dbtCsvComputeActions' = do
                   let innerAct = awaitForever $ \x
                         -> let doHandle
@@ -1017,7 +1035,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                 addMessageI Info MsgCsvImportUnnecessary
                 redirect $ tblLink id
 
-              liftHandlerT . (>>= sendResponse) $
+              liftHandler . (>>= sendResponse) $
                 siteLayoutMsg MsgCsvImportConfirmationHeading $ do
                   setTitleI MsgCsvImportConfirmationHeading
 
@@ -1033,14 +1051,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                       csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
                       csvActionCheckBox vAttrs act = do
                         let
-                          sJsonField :: Field (HandlerT UniWorX IO) csvAction
+                          sJsonField :: Field (HandlerFor UniWorX) csvAction
                           sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
                             [whamlet|
                               $newline never
                               <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
-                  (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandlerT . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
+                  (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
                   let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
                         { formMethod = POST
                         , formAction = Just $ tblLink id
@@ -1052,14 +1070,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
                   $(widgetFile "csv-import-confirmation-wrapper")
 
-        let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv)
+        hdr <- dbtCsvHeader Nothing
         catches importCsv
           [ Catch.Handler $ \case
               (DBCsvDuplicateKey{..} :: DBCsvException k')
-                -> liftHandlerT $ sendResponseStatus badRequest400 =<< do
+                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                      mr <- getMessageRender
 
-                     let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
+                     let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
                          heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]
 
                      siteLayoutMsg heading $ do
@@ -1070,10 +1088,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                          ^{offendingCsv}
                        |]
               (DBCsvException{..} :: DBCsvException k')
-                -> liftHandlerT $ sendResponseStatus badRequest400 =<< do
+                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                      mr <- getMessageRender
 
-                     let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ]
+                     let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
                          heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]
 
                      siteLayoutMsg heading $ do
@@ -1098,7 +1116,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       . setParam (wIdent "page") Nothing
       . setParam (wIdent "pagination") Nothing
 
-    table' :: HandlerSite m ~ UniWorX => WriterT x m Widget
+    table' :: WriterT x m Widget
     table' = let
         columnCount :: Int64
         columnCount = olength64 $ getColonnade dbtColonnade
@@ -1182,7 +1200,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   where
     tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
-      tbl <- liftHandlerT $ widgetToPageContent tbl'
+      tbl <- liftHandler $ widgetToPageContent tbl'
       withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
 
     setParams :: Text -> [Text] -> QueryText -> QueryText
@@ -1191,26 +1209,27 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key = setParams key . maybeToList
 
-dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
+dbTableWidget :: Monoid x
-    -> DB (DBResult (HandlerT UniWorX IO) x)
+              => PSValidator (HandlerFor UniWorX) x
+              -> DBTable (HandlerFor UniWorX) x
+              -> DB (DBResult (HandlerFor UniWorX) x)
 dbTableWidget = dbTable
 
-dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
+dbTableWidget' :: PSValidator (HandlerFor UniWorX) ()
+               -> DBTable (HandlerFor UniWorX) ()
+               -> DB Widget
 dbTableWidget' = fmap (fmap snd) . dbTable
 
-widgetColonnade :: (Headedness h, Monoid' x)
+widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-                => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
+                -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
-                -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
 widgetColonnade = id
 
-formColonnade :: (Headedness h, Monoid' a)
+formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-              => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
+              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
-dbColonnade :: (Headedness h, Monoid' x)
+dbColonnade :: Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
 dbColonnade = id
 
 pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
@@ -1271,17 +1290,17 @@ anchorCell' :: ( IsDBTable m a
            -> (r -> DBCell m a)
 anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
 
-anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
+anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
 anchorCellM routeM widget = anchorCellM' routeM id (const widget)
 
-anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a
+anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
 anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
 
 -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
-linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
+linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a
 linkEitherCell = linkEitherCellM . return
 
-linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a
+linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => WidgetFor UniWorX url -> (wgt, wgt') -> DBCell m a
 linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)
 
 linkEitherCellM' :: forall m url wgt wgt' a x.
@@ -1289,16 +1308,15 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
                     , ToWidget UniWorX wgt
                     , ToWidget UniWorX wgt'
                     , IsDBTable m a
-                    , HandlerSite m ~ UniWorX
                     )
-                 => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
+                 => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
 linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
   x <- xM
   let route        = x2route        x
-      widget, widgetUnauth :: WidgetT UniWorX IO ()
+      widget, widgetUnauth :: Widget
       widget       = toWidget $ x2widgetAuth   x
       widgetUnauth = toWidget $ x2widgetUnauth x
-  authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
+  authResult <- liftHandler $ isAuthorized (urlRoute route) False
   linkUrl <- toTextUrl route
   case authResult of
     Authorized -> $(widgetFile "table/cell/link") -- show allowed link
@@ -1324,17 +1342,17 @@ instance Ord i => Monoid (DBFormResult i a r) where
   mempty = DBFormResult Map.empty
   mappend = (<>)
 
-getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
+getDBFormResult :: forall r i a. (r -> a) -> DBFormResult i a r -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
 
-formCell :: forall x r i a. (Ord i, Monoid x)
+formCell :: forall x r i a. Monoid x
          => Lens' x (FormResult (DBFormResult i a (DBRow r)))   -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
-         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)          -- ^ generate row identfifiers for use in form result
+         -> (DBRow r -> MForm (HandlerFor UniWorX) i)          -- ^ generate row identfifiers for use in form result
-         -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
+         -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerFor UniWorX) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
+         -> (DBRow r -> DBCell (MForm (HandlerFor UniWorX)) x)
 formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
   { formCellAttrs    = []
-  , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
+  , formCellContents = do -- MForm (HandlerFor UniWorX) (FormResult (Map i (Endo a)), Widget)
       i <- lift $ genIndex input
       hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
       let
@@ -1354,11 +1372,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
 dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
-dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
+dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
          => Lens' x (FormResult (DBFormResult i a (DBRow r)))
          -> Setter' a Bool
-         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
+         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
-         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
+         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
 -- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
 dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty) $ formCell resLens genIndex genForm
   where

src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs

@@ -57,8 +57,7 @@ instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 C c a) where
 
 -- | Instance to ensure that you cannot derive DefaultOrdered for
 -- constructors without selectors.
-instance CsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a ())
+instance GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
-      => GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
    where
      gCsvColumnsExplanations _ _ =
         error "You cannot derive CsvColumnsExplanations for constructors without selectors."

src/Handler/Utils/Table/Pagination/Types.hs

@@ -18,6 +18,7 @@ import Data.CaseInsensitive (CI)
 
 import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
 
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
 newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
   deriving (Show, Read, Generic)

src/Handler/Utils/Tokens.hs

@@ -17,7 +17,7 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
       ]
 
 requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
-requireBearerToken = liftHandlerT $ do
+requireBearerToken = liftHandler $ do
   token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
   mAuthId <- maybeAuthId
   currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
@@ -25,18 +25,24 @@ requireBearerToken = liftHandlerT $ do
   guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
   return token
 
-maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
+requireCurrentTokenRestrictions :: ( MonadHandler m
-                                                                  , HandlerSite m ~ UniWorX
+                                   , HandlerSite m ~ UniWorX
-                                                                  , MonadCatch m
+                                   , FromJSON a
-                                                                  , MonadLogger m
+                                   , ToJSON a
-                                                                  , FromJSON a
+                                   )
-                                                                  , ToJSON a
+                                => m (Maybe a)
-                                                                  )
-                                                               => m (Maybe a)
 requireCurrentTokenRestrictions = runMaybeT $ do
   token <- requireBearerToken
   route <- MaybeT getCurrentRoute
   hoistMaybe $ token ^? _tokenRestrictionIx route
+  
+maybeCurrentTokenRestrictions :: ( MonadHandler m
+                                 , HandlerSite m ~ UniWorX
+                                 , MonadCatch m
+                                 , FromJSON a
+                                 , ToJSON a
+                                 )
+                              => m (Maybe a)
 maybeCurrentTokenRestrictions = runMaybeT $ do
   token <- MaybeT maybeBearerToken
   route <- MaybeT getCurrentRoute

src/Handler/Utils/Zip.hs

@@ -30,6 +30,15 @@ import Data.List (dropWhileEnd)
 
 import qualified Data.Map as Map
 
+import qualified Data.Conduit.List as C
+
+
+import Data.Encoding ( decodeStrictByteStringExplicit
+                     , encodeStrictByteStringExplicit
+                     )
+import Data.Encoding.CP437
+import qualified Data.Char as Char
+
 
 typeZip :: ContentType
 typeZip = "application/zip"
@@ -45,30 +54,33 @@ instance Default ZipInfo where
     }
 
 
-consumeZip :: ( MonadBase b m
+consumeZip :: forall b m.
-              , PrimMonad b
+              ( MonadThrow b
               , MonadThrow m
-              ) => ConduitM ByteString File m ZipInfo
+              , MonadBase b m
-consumeZip = unZipStream `fuseUpstream` consumeZip'
+              , PrimMonad b
+              )
+           => ConduitT ByteString File m ZipInfo
+consumeZip = transPipe liftBase unZipStream `fuseUpstream` consumeZip'
   where
-    consumeZip' :: ( MonadThrow m
+    consumeZip' :: ConduitT (Either ZipEntry ByteString) File m ()
-                   ) => Conduit (Either ZipEntry ByteString) m File
     consumeZip' = do
       input <- await
       case input of
         Nothing -> return ()
-        Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
+        Just (Right _) -> throwM $ userError "Data chunk in unexpected place when parsing ZIP"
         Just (Left ZipEntry{..}) -> do
           contentChunks <- toConsumer accContents
+          zipEntryName' <- decodeZipEntryName zipEntryName
           let
-            fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
+            fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName'
             fileModified = localTimeToUTC utc zipEntryTime
             fileContent
-              | hasTrailingPathSeparator zipEntryName = Nothing
+              | hasTrailingPathSeparator zipEntryName' = Nothing
               | otherwise = Just $ mconcat contentChunks
           yield File{..}
           consumeZip'
-    accContents :: Monad m => Sink (Either a b) m [b]
+    accContents :: ConduitT (Either a b') Void m [b']
     accContents = do
       input <- await
       case input of
@@ -76,12 +88,15 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
         Just (Left x)  -> []    <$ leftover (Left x)
         _ -> return []
 
-produceZip :: ( MonadBase b m
+produceZip :: forall b m.
-              , PrimMonad b
+            ( MonadThrow b
-              , MonadThrow m
+            , MonadThrow m
-              ) => ZipInfo
+            , MonadBase b m
-              -> Conduit File m ByteString
+            , PrimMonad b
-produceZip info = mapC toZipData =$= void (zipStream zipOptions)
+            )
+           => ZipInfo
+           -> ConduitT File ByteString m ()
+produceZip info = C.map toZipData .| transPipe liftBase (void $ zipStream zipOptions)
   where
     zipOptions = ZipOptions
       { zipOpt64 = True
@@ -89,35 +104,60 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
       , zipOptInfo = info
       }
 
-    toZipData :: Monad m => File -> (ZipEntry, ZipData m)
+    toZipData :: File -> (ZipEntry, ZipData b)
-    toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
+    toZipData f@File{..} =
+      let zData = maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent
+          zEntry = (toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }
+       in (zEntry, zData)
 
     toZipEntry :: File -> ZipEntry
-    toZipEntry File{..} = ZipEntry
+    toZipEntry File{..} = ZipEntry{..}
-      { zipEntryName = bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
-      , zipEntryTime = utcToLocalTime utc fileModified
-      }
       where
         isDir = isNothing fileContent
+  
+        zipEntryName = encodeZipEntryName . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise $ makeValid fileTitle
+        zipEntryTime = utcToLocalTime utc fileModified
+        zipEntrySize = Nothing
+        zipEntryExternalAttributes = Nothing
 
-modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
+modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m ()
 modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
 
 -- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
-sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
+sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
 sourceFiles fInfo
     | ((==) `on` simpleContentType) mimeType typeZip = do
         $logInfoS "sourceFiles" "Unpacking ZIP"
-        fileSource fInfo =$= void consumeZip
+        fileSource fInfo .| void consumeZip
     | otherwise = do
         $logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
         yieldM $ acceptFile fInfo
   where
     mimeType = mimeLookup $ fileName fInfo
 
-acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
+acceptFile :: MonadResource m => FileInfo -> m File
 acceptFile fInfo = do
   let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
   fileModified <- liftIO getCurrentTime
-  fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
+  fileContent <- fmap Just . runConduit $ fileSource fInfo .| foldC
   return File{..}
+
+  
+decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath
+-- ^ Extract the filename from a 'ZipEntry' doing decoding along the way.
+--
+-- Throws 'Data.Encoding.Exception.DecodingException's.
+decodeZipEntryName = \case
+  Left  t     -> return $ unpack t
+  Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437
+  
+encodeZipEntryName :: FilePath -> Either Text ByteString
+-- ^ Encode a filename for use in a 'ZipEntry', encodes as
+--   'Data.Encoding.UTF8.UTF8' iff the given path contains non-ascii characters.
+--
+-- Does not do any normalisation (in particular this function does not ensure
+-- that the 'FilePath' does not start with a slash).
+encodeZipEntryName path = fromMaybe (Left $ pack path) $ do
+  guard $ all Char.isAscii path
+
+  either (const mzero) (return . Right) $ encodeStrictByteStringExplicit CP437 path

src/Import/NoModel.hs

@@ -12,11 +12,15 @@ import ClassyPrelude.Yesod    as Import
          , Proxy
          , foldlM
          , static
-         , boolField, identifyForm
+         , boolField, identifyForm, addClass
          , HasHttpManager(..)
          , embed
+         , try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
+         , fail
          )
 
+import UnliftIO.Async.Utils as Import
+
 import Model.Types.TH.JSON as Import
 import Model.Types.TH.Wordlist as Import
 
@@ -44,7 +48,7 @@ import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
 import Data.Universe.TH       as Import
-import Data.Pool              as Import (Pool)
+import UnliftIO.Pool          as Import (Pool)
 import Network.HaskellNet.SMTP as Import (SMTPConnection)
 
 import Data.Data              as Import (Data)
@@ -80,6 +84,14 @@ import Control.Monad.Trans.Reader as Import
   ( reader, Reader, runReader, mapReader, withReader
   , ReaderT(..), mapReaderT, withReaderT
   )
+import Control.Monad.Trans.State as Import
+  ( state, State, runState, mapState, withState
+  , StateT(..), mapStateT, withStateT
+  )
+import Control.Monad.Base as Import
+import Control.Monad.Catch as Import hiding (Handler(..))
+import Control.Monad.Trans.Control as Import hiding (embed)
+import Control.Monad.Fail as Import
 
 import Jose.Jwt as Import (Jwt)
 
@@ -101,7 +113,6 @@ import Algebra.Lattice as Import hiding (meet, join)
 import Data.Proxy as Import (Proxy(..))
 
 import Language.Haskell.TH.Instances as Import ()
-import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Monoid.Instances  as Import ()
 import Data.Maybe.Instances  as Import ()
@@ -141,7 +152,7 @@ import Control.Lens as Import
   hiding ( (<.>)
          , universe
          , cons, uncons, snoc, unsnoc, (<|)
-         , Index, index, (<.)
+         , Index, index, (<.), (.>)
          )
 import Control.Lens.Extras as Import (is)
 import Data.Set.Lens as Import

src/Jobs.hs

@@ -44,7 +44,7 @@ import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
 import qualified Control.Monad.State.Class as State
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT)
+import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Cont (ContT(..), callCC)
 import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
@@ -55,6 +55,8 @@ import Data.Time.Zones
 import Control.Concurrent.STM (retry)
 import Control.Concurrent.STM.Delay
 
+import UnliftIO.Concurrent (forkIO)
+
 
 import Jobs.Handler.SendNotification
 import Jobs.Handler.SendTestEmail
@@ -82,7 +84,8 @@ instance Exception JobQueueException
 
 
 handleJobs :: ( MonadResource m
-              , MonadLoggerIO m
+              , MonadLogger m
+              , MonadUnliftIO m
               )
            => UniWorX -> m ()
 -- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
@@ -92,12 +95,11 @@ handleJobs :: ( MonadResource m
 handleJobs foundation@UniWorX{..}
   | foundation ^. _appJobWorkers == 0 = return ()
   | otherwise = do
-      logger <- askLoggerIO
+      UnliftIO{..} <- askUnliftIO
-      let runInIO = flip runLoggingT logger . runResourceT
 
-      jobPoolManager <- allocateLinkedAsync . runInIO $ manageJobPool foundation
+      jobPoolManager <- allocateLinkedAsync . unliftIO $ manageJobPool foundation
 
-      jobCron <- allocateLinkedAsync . runInIO $ manageCrontab foundation
+      jobCron <- allocateLinkedAsync . unliftIO $ manageCrontab foundation
 
       let jobWorkers = Map.empty
           jobWorkerName = const $ error "Unknown worker"
@@ -109,11 +111,9 @@ handleJobs foundation@UniWorX{..}
         , ..
         }
 
-manageJobPool, manageCrontab :: forall m.
+manageCrontab :: forall m.
-                                ( MonadResource m
+                 MonadResource m
-                                , MonadLogger m
+              => UniWorX -> m ()
-                                )
-                             => UniWorX -> m ()
 manageCrontab foundation@UniWorX{..} = do
   context <- atomically . fmap jobContext $ readTMVar appJobState
   let awaitTermination = atomically $ do
@@ -125,7 +125,12 @@ manageCrontab foundation@UniWorX{..} = do
       writeJobCtlBlock JobCtlDetermineCrontab
     evalRWST (forever execCrontab) context HashMap.empty
 
-
+manageJobPool :: forall m.
+                 ( MonadResource m
+                 , MonadLogger m
+                 , MonadUnliftIO m
+                 )
+              => UniWorX -> m ()
 manageJobPool foundation@UniWorX{..}
   = flip runContT return . forever . join . atomically $ asum
       [ spawnMissingWorkers
@@ -138,6 +143,9 @@ manageJobPool foundation@UniWorX{..}
 
     spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ())
     spawnMissingWorkers = do
+      shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
+      guard $ not shouldTerminate'
+  
       oldState <- takeTMVar appJobState
       let missing = num - Map.size (jobWorkers oldState)
       guard $ missing > 0
@@ -163,7 +171,7 @@ manageJobPool foundation@UniWorX{..}
               $logInfoS logIdent "Started"
               runConduit $ streamChan .| handleJobs' workerId
               $logInfoS logIdent "Stopped"
-          worker <- allocateLinkedAsync runWorker
+          worker <- lift . lift $ allocateLinkedAsync runWorker
 
           tell . Endo $ \cSt -> cSt
             { jobWorkers = Map.insert worker chan $ jobWorkers cSt
@@ -199,28 +207,32 @@ manageJobPool foundation@UniWorX{..}
     terminateGracefully = do
       shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
       guard shouldTerminate
+
+      oldState <- takeTMVar appJobState
+      guard $ 0 == Map.size (jobWorkers oldState)
+
       return . callCC $ \terminate -> do
         $logInfoS "JobPoolManager" "Shutting down"
         terminate ()
 
-stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
+stopJobCtl :: MonadUnliftIO m => UniWorX -> m ()
 -- ^ Stop all worker threads currently running
 stopJobCtl UniWorX{appJobState} = do
   didStop <- atomically $ do
     jState <- tryReadTMVar appJobState
     for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown ()
-  whenIsJust didStop $ \jSt' -> void . fork . atomically $ do
+  whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do
     workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState
     mapM_ (void . waitCatchSTM) $
       [ jobPoolManager jSt'
       , jobCron jSt'
       ] ++ workers
 
-execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) ()
+execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
 -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
 --   seen, wait for the time of the next job and fire it
 execCrontab = do
-  mapRWST (liftHandlerT . runDB . setSerializable) $ do
+  mapRWST (liftHandler . runDB . setSerializable) $ do
     let
       mergeLastExec (Entity _leId CronLastExec{..})
         | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
@@ -251,7 +263,7 @@ execCrontab = do
   --   now <- liftIO getCurrentTime
   --   $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
 
-  let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do
+  let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
           newCrontab <- lift . hoist lift $ determineCrontab'
           if
             | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
@@ -305,7 +317,7 @@ execCrontab = do
           where
             t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
 
-    waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
+    waitUntil :: (Eq a, MonadUnliftIO m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
     waitUntil crontabTV crontab nextTime = runResourceT $ do
       diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
       let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
@@ -328,7 +340,7 @@ execCrontab = do
 mkLogIdent :: JobWorkerId -> Text
 mkLogIdent wId = "Job-Executor " <> showWorkerId wId
 
-handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) ()
+handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) ()
 handleJobs' wNum = C.mapM_ $ \jctl -> do
   $logDebugS logIdent $ tshow jctl
   res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
@@ -348,7 +360,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
     handleQueueException (JLocked jId lInstance lTime)  = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
 
     handleCmd JobCtlTest = return ()
-    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (lift . writeJobCtl . JobCtlPerform)
+    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod)
     handleCmd (JobCtlQueue job) = lift $ queueJob' job
     handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
       content <- case fromJSON queuedJobContent of
@@ -379,7 +391,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
             ]
         delete jId
     handleCmd JobCtlDetermineCrontab = do
-      newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
+      newCTab <- liftHandler . runDB $ setSerializable determineCrontab'
       -- logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
         lift . void . flip swapTVar newCTab =<< asks jobCrontab
@@ -454,5 +466,5 @@ determineCrontab' :: DB (Crontab JobCtl)
 determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
 
 
-performJob :: Job -> HandlerT UniWorX IO ()
+performJob :: Job -> HandlerFor UniWorX ()
 performJob = $(dispatchTH ''Job)

src/Jobs/Handler/HelpRequest.hs

@@ -19,7 +19,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
 dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
-  supportAddress <- view _appMailSupport
+  supportAddress <- getsYesod $ view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let senderAddress = either
         id

src/Jobs/Handler/SendCourseCommunication.hs

@@ -6,8 +6,6 @@ import Import
 
 import Handler.Utils
 
-import qualified Data.Set as Set
-
 import qualified Data.CaseInsensitive as CI
 
 
@@ -26,11 +24,11 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
   either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
     void $ setMailObjectUUID jMailObjectUUID
     _mailFrom .= userAddress sender
-    if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
+    addMailHeader "Cc" "Undisclosed Recipients:;"
-      | jRecipientEmail == Right jSender
-      -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
-      | otherwise
-      -> addMailHeader "Cc" "Undisclosed Recipients:;"
     addMailHeader "Auto-Submitted" "no"
     setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
     void $ addPart jMailContent
+    when (jRecipientEmail == Right jSender) $
+      addPart' $ do
+        partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv
+        toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses

src/Jobs/Handler/SendNotification/Allocation.hs

@@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E
 
 dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do
-  Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
+  Allocation{..} <- liftHandler . runDB $ getJust nAllocation
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationName
@@ -32,7 +32,7 @@ dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT j
 
 dispatchNotificationAllocationRegister :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecipient $ do
-  Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
+  Allocation{..} <- liftHandler . runDB $ getJust nAllocation
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectAllocationRegister allocationName
@@ -43,7 +43,7 @@ dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecip
 
 dispatchNotificationAllocationAllocation :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationAllocation nAllocation jRecipient = do
-  (Allocation{..}, courses) <- liftHandlerT . runDB $ do
+  (Allocation{..}, courses) <- runDB $ do
     allocation <- getJust nAllocation
     courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
       E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@@ -75,7 +75,7 @@ dispatchNotificationAllocationAllocation nAllocation jRecipient = do
 
 dispatchNotificationAllocationUnratedApplications :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
-  (Allocation{..}, courses) <- liftHandlerT . runDB $ do
+  (Allocation{..}, courses) <- runDB $ do
     allocation <- getJust nAllocation
     courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
       E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@@ -117,7 +117,7 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
 
 dispatchNotificationAllocationOutdatedRatings :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
-  (Allocation{..}, courses) <- liftHandlerT . runDB $ do
+  (Allocation{..}, courses) <- runDB $ do
     allocation <- getJust nAllocation
     courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
       E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -14,7 +14,7 @@ import qualified Data.CaseInsensitive as CI
 
 dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
 dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
-  (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
+  (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
     sheet <- getJust nSheet
     course <- belongsToJust sheetCourse sheet
     nbrSubs <- count [ SubmissionSheet      ==. nSheet

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

@@ -11,7 +11,7 @@ import qualified Data.CaseInsensitive as CI
 
 dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
 dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
-  (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
+  (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
     sheet <- getJust nSheet
     course <- belongsToJust sheetCourse sheet
     nbrSubs <- count [ SubmissionSheet      ==. nSheet

src/Jobs/Handler/SendNotification/ExamActive.hs

@@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI
 
 dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Handler ()
 dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipient $ do
-  (Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
+  (Course{..}, Exam{..}) <- liftHandler . runDB $ do
     exam <- getJust nExam
     course <- belongsToJust examCourse exam
     return (course, exam)
@@ -37,7 +37,7 @@ dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipie
 
 dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler ()
 dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
-  (Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
+  (Course{..}, Exam{..}) <- liftHandler . runDB $ do
     exam <- getJust nExam
     course <- belongsToJust examCourse exam
     return (course, exam)
@@ -58,7 +58,7 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jR
 
 dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler ()
 dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
-  (Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
+  (Course{..}, Exam{..}) <- liftHandler . runDB $ do
     exam <- getJust nExam
     course <- belongsToJust examCourse exam
     return (course, exam)