Merge branch 'master' into feat/modalicons

.gitignore

@@ -1,8 +1,6 @@
 dist*
 static/tmp/
 static/combined/
-client_session_key.aes
-cryptoid_key.bf
 *.hi
 *.o
 *.sqlite3
@@ -29,6 +27,8 @@ uniworx.nix
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
+/instance
 .stack-work-*
 .directory
 tags
+test.log

.hlint.yaml

@@ -0,0 +1,14 @@
+# HLint configuration file                                                 
+# https://github.com/ndmitchell/hlint                                      
+##########################
+
+  - ignore: { name: "Parse error" }
+  - ignore: { name: "Reduce duplication" }
+  - ignore: { name: "Use ||" }
+  - ignore: { name: "Use &&" }
+  - ignore: { name: "Use ++" }
+
+  - arguments:
+      - -XQuasiQuotes
+      - -XTemplateHaskell
+      - -j

.vscode/settings.json

@@ -0,0 +1,3 @@
+{
+  "AllAutocomplete.showCurrentDocument": false
+}

.vscode/tasks.json

@@ -0,0 +1,48 @@
+{
+  "version": "2.0.0",
+  "tasks": [
+    {
+      "label": "build",
+      "type": "shell",
+      "command": "./build.sh",
+      "group": {
+        "kind": "build",
+        "isDefault": true
+      },
+      "presentation": {
+        "echo": true,
+        "reveal": "always",
+        "focus": false,
+        "panel": "dedicated",
+        "showReuseMessage": false
+      }
+    },
+    {
+      "label": "start",
+      "type": "shell",
+      "command": "./start.sh",
+      "group": "build",
+      "presentation": {
+        "echo": true,
+        "reveal": "silent",
+        "focus": false,
+        "panel": "dedicated",
+        "showReuseMessage": false
+      },
+      "problemMatcher": []
+    },
+    {
+      "label": "test",
+      "type": "shell",
+      "command": "./test.sh",
+      "group": "test",
+      "presentation": {
+        "echo": true,
+        "reveal": "always",
+        "focus": true,
+        "panel": "dedicated",
+        "showReuseMessage": false
+      }
+    }
+  ]
+}

ChangeLog.md

@@ -1,3 +1,37 @@
+  * Version 30.01.2019
+  
+    Designänderungen
+
+  * Version 16.01.2019
+
+    Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt)
+
+    Liste zugewiesener Abgaben lassen sich nun filtern
+    
+    Bugfix: Wenn zwischen Anzeige und Empfang eines Tabellen-Formulars Zeilen verschwinden wird nun eine sinnvolle Fehlermeldung angezeigt
+
+  * Version 30.11.2018
+
+    Bugfix: Übungsblätter im "bestehen nach Punkten"-Modus werden wieder korrekt gespeichert
+
+  * Version 29.11.2018
+
+    Bugfix: Formulare innerhalb von Tabellen funktionieren nun auch nach Javascript-Seitenwechsel oder Ändern der Sortierung
+
+  * Version 09.11.2018
+
+    Bugfix: Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
+
+    Verschiedene Verbesserungen für Korrektoren
+
+  * Version 19.10.2018
+
+    Benutzer können sich in der Testphase komplett selbst löschen
+
+    Hilfe Widget
+
+    Benachrichtigungen per eMail für einige Ereignisse
+
   * Version 18.09.2018
 
     Tooltips funktionieren auch ohne JavaScript
@@ -9,11 +43,11 @@
     Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen
 
     Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
-    
+
     Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen
 
   * Version 06.08.2018
-  
+
     Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen
 
   * Version 01.08.2018

README.md

@@ -1,118 +0,0 @@
-# Quick Start Guide
-
-The following Description applies to Ubuntu or similar.
-
-## Clone repository
-  Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`.
-
-## LDAP
-  install:  
-  `sudo apt-get install slapd ldap-utils`
-
-
-## PostgreSQL
-  install:  
-  `sudo apt-get install postgresql`
-
-  switch to user *postgres* (got created during installation):  
-  `sudo -i -u postgres`
-
-  add db user *uniworx*:  
-  `createuser --interactive`
-
-  you'll get a prompt:
-
-  ```
-  Enter name of role to add:` - [enter 'uniworx']
-  Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
-  ```
-
-  create database *uniworx*:  
-  `createdb uniworx`
-
-  to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:  
-  `sudo adduser uniworx`
-
-  log-in as new user *uniworx*:  
-  `sudo -i -u uniworx`
-
-  you can now use `psql uniworx` to execute SQL-commands and such.
-
-## stack
-  Install with:  
-  `curl -sSL https://get.haskellstack.org/ | sh`
-
-  setup stack and install dependencies:  
-  `stack setup`
-
-  During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using  
-  `sudo apt-get install libsasl2-dev libldap2-dev`
-
-  If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*  
-  Go ahead an install `libpq-dev` with  
-  `sudo apt-get install libpq-dev`
-
-  Build the app:  
-  `stack build`
-
-  This might take a few minutes if not hours... be prepared.
-
-  install yesod:  
-  `stack install yesod-bin --install-ghc`
-
-## Add Dumy-Data and run the app
-  After building the app you can prepare the database and add some dummy data:
-  `./fill-db.hs`
-
-  Run the app:  
-  `./start.sh`
-
-  `Devel application launched: http://localhost:3000`  
-  means you are good to go.
-
-  If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
-
-***
-
-# Sources and more infos
-  PostgreSQl:   
-  https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04
-
-  stack:   https://docs.haskellstack.org/en/stable/README/#how-to-install
-
-  ldap:  https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/
-
-
-***
-
-# PostgreSQL
-
-Starten als Root:
-
-# systemctl start postgresql
-# find / -name postgresql.conf
-# cd /var/lib/pgsql/data/
-# su - postgres
-
-
-psql -U uniworx -d uniworx -h 127.0.0.1 -w
-
---Zeige Tabellen
-\dt
-
---Zeige Tabellen Inhalt:
-TABLE "user";
--- Die Anführungszeichen können manchmal weggelassen werden, aber
--- bei user sind sie notwendig, da es auch Schlüsselwort in sql ist.
-
---Lösche Tabelle "course" und alle davon abhängigen:
-DROP TABLE "course" CASCADE;
-
--- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
-INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1);
-
--- Beenden:
-\q
-
--- Hilfe:
-\help

app/DevelMain.hs

@@ -33,13 +33,15 @@ module DevelMain where
 import Prelude
 import Application (getApplicationRepl, shutdownApp)
 
-import Control.Exception (finally)
+import Control.Monad.Catch (finally)
 import Control.Monad ((>=>))
 import Control.Concurrent
 import Data.IORef
 import Foreign.Store
 import Network.Wai.Handler.Warp
 import GHC.Word
+import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class
 
 -- | Start or restart the server.
 -- newStore is from foreign-store.
@@ -71,13 +73,14 @@ update = do
     -- | Start the server in a separate thread.
     start :: MVar () -- ^ Written to when the thread is killed.
           -> IO ThreadId
-    start done = do
-        (port, site, app) <- getApplicationRepl
-        forkIO (finally (runSettings (setPort port defaultSettings) app)
-                        -- Note that this implies concurrency
-                        -- between shutdownApp and the next app that is starting.
-                        -- Normally this should be fine
-                        (putMVar done () >> shutdownApp site))
+    start done = runResourceT $ do
+      (port, site, app) <- getApplicationRepl
+      resourceForkIO $ do
+        finally (liftIO $ runSettings (setPort port defaultSettings) app)
+          -- Note that this implies concurrency
+          -- between shutdownApp and the next app that is starting.
+          -- Normally this should be fine
+          (liftIO $ putMVar done () >> shutdownApp site)
 
 -- | kill the server
 shutdown :: IO ()

build.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+
+exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev

config/keter_testworx.yml

@@ -27,13 +27,37 @@ stanzas:
       - LDAPPASS
       - LDAPBASE
       - LDAPSCOPE
+      - LDAPSEARCHTIME
+      - LDAPSTRIPES
       - LDAPTIMEOUT
+      - LDAPLIMIT
       - DUMMY_LOGIN
       - DETAILED_LOGGING
       - LOG_ALL
+      - LOGLEVEL
+      - ALLOW_DEPRECATED
       - PWFILE
       - CRYPTOID_KEYFILE
       - IP_FROM_HEADER
+      - MAILFROM_NAME
+      - MAILFROM_EMAIL
+      - MAILOBJECT_DOMAIN
+      - SMTPHOST
+      - SMTPPORT
+      - SMTPSSL
+      - SMTPUSER
+      - SMTPPASS
+      - SMTPTIMEOUT
+      - SMTPLIMIT
+      - MAILSUPPORT
+      - MAILSUPPORT_NAME
+      - INSTANCE_ID
+      - MEMCACHEDHOST
+      - MEMCACHEDPORT
+      - MEMCACHEDLIMIT
+      - MEMCACHEDTIMEOUT
+      - MEMCACHEDROOT
+      - MEMCACHEDEXPIRATION
 
 # Use the following to automatically copy your bundle upon creation via `yesod
 # keter`. Uses `scp` internally, so you can set it to a remote destination

config/keter_uni2work.yml

@@ -27,12 +27,37 @@ stanzas:
       - LDAPPASS
       - LDAPBASE
       - LDAPSCOPE
+      - LDAPSEARCHTIME
+      - LDAPSTRIPES
       - LDAPTIMEOUT
+      - LDAPLIMIT
       - DETAILED_LOGGING
       - LOG_ALL
+      - LOGLEVEL
+      - ALLOW_DEPRECATED
       - PWFILE
       - CRYPTOID_KEYFILE
       - IP_FROM_HEADER
+      - MAILFROM_NAME
+      - MAILFROM_EMAIL
+      - MAILOBJECT_DOMAIN
+      - SMTPHOST
+      - SMTPPORT
+      - SMTPSSL
+      - SMTPUSER
+      - SMTPPASS
+      - SMTPTIMEOUT
+      - SMTPLIMIT
+      - MAILSUPPORT
+      - MAILSUPPORT_NAME
+      - INSTANCE_ID
+      - MEMCACHEDHOST
+      - MEMCACHEDPORT
+      - MEMCACHEDLIMIT
+      - MEMCACHEDTIMEOUT
+      - MEMCACHEDROOT
+      - MEMCACHEDEXPIRATION
+
 
 # Use the following to automatically copy your bundle upon creation via `yesod
 # keter`. Uses `scp` internally, so you can set it to a remote destination

config/settings.yml

@@ -8,10 +8,33 @@ host:           "_env:HOST:*4" # any IPv4 host
 port:           "_env:PORT:3000"
 ip-from-header: "_env:IP_FROM_HEADER:false"
 approot:        "_env:APPROOT:http://localhost:3000"
+mail-from:
+  name:         "_env:MAILFROM_NAME:Uni2work"
+  email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
+mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
+mail-verp:
+  separator:    "+"
+  at-replacement: "="
+mail-support:
+  name:         "_env:MAILSUPPORT_NAME:"
+  email:        "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
 
-detailed-logging:  "_env:DETAILED_LOGGING:false"
-should-log-all:    "_env:LOG_ALL:false"
-minimum-log-level: "_env:LOGLEVEL:warn"
+job-workers:        "_env:JOB_WORKERS:10"
+job-flush-interval: "_env:JOB_FLUSH:30"
+job-cron-interval:  "_env:CRON_INTERVAL:60"
+job-stale-threshold: 300
+notification-rate-limit: 3600
+notification-collate-delay: 300
+notification-expiration: 259201
+session-timeout: 7200
+
+log-settings:
+  detailed:      "_env:DETAILED_LOGGING:false"
+  all:           "_env:LOG_ALL:false"
+  minimum-level: "_env:LOGLEVEL:warn"
+  destination:   "_env:LOGDEST:stderr"
+
+# Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
 
@@ -20,10 +43,11 @@ auth-pw-hash:
   strength: 14
 
 # Optional values with the following production defaults.
-# In development, they default to true.
+# In development, they default to the opposite.
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
+# encrypt-errors: true
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -43,6 +67,33 @@ ldap:
   baseDN:  "_env:LDAPBASE:"
   scope:   "_env:LDAPSCOPE:WholeSubtree"
   timeout: "_env:LDAPTIMEOUT:5"
+  search-timeout: "_env:LDAPSEARCHTIME:5"
+  pool:
+    stripes: "_env:LDAPSTRIPES:1"
+    timeout: "_env:LDAPTIMEOUT:20"
+    limit:   "_env:LDAPLIMIT:10"
+
+smtp:
+  host:    "_env:SMTPHOST:"
+  port:    "_env:SMTPPORT:25"
+  ssl:     "_env:SMTPSSL:starttls"
+  auth:
+    type:  "login"
+    user:  "_env:SMTPUSER:"
+    pass:  "_env:SMTPPASS:"
+  pool:
+    stripes: "_env:SMTPSTRIPES:1"
+    timeout: "_env:SMTPTIMEOUT:20"
+    limit:   "_env:SMTPLIMIT:10"
+
+widget-memcached:
+  host:       "_env:MEMCACHEDHOST:"
+  port:       "_env:MEMCACHEDPORT:11211"
+  auth:       []
+  limit:      "_env:MEMCACHEDLIMIT:10"
+  timeout:    "_env:MEMCACHEDTIMEOUT:20"
+  base-url:   "_env:MEMCACHEDROOT:"
+  expiration: "_env:MEMCACHEDEXPIRATION:3600"
 
 user-defaults:
   max-favourites:   12
@@ -52,4 +103,4 @@ user-defaults:
   time-format:      "%R"
   download-files:   false
 
-cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
+instance-id: "_env:INSTANCE_ID:instance"

config/submission-blacklist

@@ -10,3 +10,8 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
 
 $# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS)
 **/.DS_Store
+
+$# Ignoriere VI-Style-Backup-Files
+**/*~
+$# Ignoriere Emacs-Style-Backup-Files
+**/.#*#

config/test-settings.yml

@@ -1,11 +1,10 @@
 database:
-  # NOTE: By design, this setting prevents the PGDATABASE environment variable
-  # from affecting test runs, so that we don't accidentally affect the
-  # production database during testing. If you're not concerned about that and
-  # would like to have environment variable overrides, you could instead use
-  # something like:
-  #
-  #   database: "_env:PGDATABASE:uniworx_test"
-  database: uniworx_test
+  database: "_env:PGDATABASE_TEST:uniworx_test"
+
+log-settings:
+  detailed:      true
+  all:           true
+  minimum-level: "debug"
+  destination:   "test.log"
 
 auth-dummy-login: true

db.sh

@@ -0,0 +1,4 @@
+#!/usr/bin/env -S bash -xe
+
+stack build --fast --flag uniworx:library-only --flag uniworx:dev
+stack exec uniworxdb -- $@

ghci.sh

@@ -7,13 +7,13 @@ export DUMMY_LOGIN=true
 
 move-back() {
     mv -v .stack-work .stack-work-ghci
-    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
 }
 
 if [[ -d .stack-work-ghci ]]; then
-    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
     mv -v .stack-work-ghci .stack-work
     trap move-back EXIT
 fi
 
-stack ghci --flag uniworx:dev --flag uniworx:library-only
+stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib}

haddock.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+
+exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

hlint/Hlint.hs

@@ -0,0 +1,4 @@
+{-# OPTIONS_GHC
+      -F -pgmF hlint-test
+         -optF src
+  #-}

messages/button/de.msg

@@ -0,0 +1,3 @@
+AmbiguousButtons: Mehrere Submit-Buttons aktiv
+WrongButtonValue: Submit-Button hat falschen Wert
+MultipleButtonValues: Submit-Button hat mehrere Werte

messages/dummy/de.msg

@@ -1 +1,2 @@
-DummyIdent: Nutzer-Kennung
+DummyIdent: Nutzer-Kennung
+DummyNoFormData: Keine Formulardaten empfangen

messages/uniworx/de.msg

@@ -7,6 +7,7 @@ BtnHijack: Sitzung übernehmen
 
 Aborted: Abgebrochen
 Registered: Angemeldet
+RegisteredSince date@Text: Angemeldet seit #{date}
 RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
 DeRegUntil: Abmeldungen bis
@@ -16,7 +17,7 @@ WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
 WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
 PSLimitNonPositive: “pagesize” muss größer als null sein
-Page n@Int64: #{display n}
+Page num@Int64: #{display num}
 
 TermsHeading: Semesterübersicht
 TermCurrent: Aktuelles Semester
@@ -28,6 +29,16 @@ InvalidInput: Eingaben bitte korrigieren.
 Term: Semester
 TermPlaceholder: W/S + vierstellige Jahreszahl
 
+TermStartDay: Erster Tag
+TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
+TermEndDay: Letzter Tag
+TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
+TermLectureStart: Beginn Vorlesungen
+TermLectureEnd: Ende Vorlesungen
+TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.
+TermActive: Aktiv
+
+
 SchoolListHeading: Übersicht über verwaltete Institute
 SchoolHeading school@SchoolName: Übersicht #{display school}
 
@@ -38,6 +49,7 @@ CourseShort: Kürzel
 CourseCapacity: Kapazität
 CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt
 CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
+CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
 CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
 CourseSecretWrong: Falsches Kennwort
@@ -68,9 +80,13 @@ CourseSemester: Semester
 CourseSchool: Institut
 CourseSchoolShort: Fach
 CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
-CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
+CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich
 CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
+CourseFilterSearch: Volltext-Suche
+CourseFilterRegistered: Registriert
+CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
+CourseDeleted: Kurs gelöscht
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@@ -86,11 +102,15 @@ SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand
 SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
 SheetEditOk        tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
 SheetNameDup       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
-SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
-SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
+SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
 SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
+SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
+
+SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
+SheetDeleted: Übungsblatt gelöscht
 
 SheetUploadMode: Abgabe von Dateien
+SheetSubmissionMode: Abgabe-Modus
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
 SheetHintFrom: Hinweis ab
@@ -99,7 +119,7 @@ SheetSolutionFrom: Lösung ab
 SheetMarking: Hinweise für Korrektoren
 SheetType: Wertung
 SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
-SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}!
+SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
 SheetName: Name
 SheetDescription: Hinweise für Teilnehmer
 SheetGroup: Gruppenabgabe
@@ -111,6 +131,8 @@ SheetActiveTo: Abgabefrist
 SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
 SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
 SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
+SheetPseudonym: Persönliches Abgabe-Pseudonym
+SheetGeneratePseudonym: Generieren
 
 SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
 SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
@@ -128,39 +150,54 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
 SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
 CorrectionHead     tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
-SubmissionMember g@Int: Mitabgebende(r) ##{display g}
+SubmissionMember n@Int: Mitabgebende(r) ##{display n}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
 SubmissionFiles: Abgegebene Dateien
 SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
 
+SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
+SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
+
 SubmissionGroupName: Gruppenname
 
 CorrectionsTitle: Zugewiesene Korrekturen
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
 CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
+CorrectorAssignTitle: Korrektor zuweisen
+
 
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
+UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
+UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
 UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
 UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
 UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
 UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
-UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
 UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
 UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
 UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
 UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
 UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
+UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen.
+UnauthorizedCorrectorSubmission: Korrektoren dürfen für dieses Übungsblatt keine Abgaben erstellen.
 OnlyUploadOneFile: Bitte nur eine Datei hochladen.
 DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
 UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
 MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
-UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
+UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
+UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
+UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
+UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@@ -171,6 +208,7 @@ AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
 SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
+AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
 Corrector: Korrektor
 Correctors: Korrektoren
 CorState: Status
@@ -180,8 +218,10 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile
 CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
 CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
 
+RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt
 DeleteRow: Zeile entfernen
 ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorUpdated: Korrektor erfolgreich aktualisiert
 CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
 CorrectorsPlaceholder: Korrektoren...
 CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
@@ -193,8 +233,10 @@ LoginTitle: Authentifizierung
 ProfileHeading: Benutzereinstellungen
 ProfileDataHeading: Gespeicherte Benutzerdaten
 ImpressumHeading: Impressum
+SystemMessageHeading: Uni2work Statusmeldung
+SystemMessageListHeading: Uni2work Statusmeldungen
 
-NumCourses n@Int64: #{display n} Kurse
+NumCourses num@Int64: #{display num} Kurse
 CloseAlert: Schliessen
 
 Name: Name
@@ -210,15 +252,21 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
 
 NrColumn: Nr
 SelectColumn: Auswahl
+DBTablePagesize: Einträge pro Seite
+DBTablePagesizeAll: Alle
 
 CorrDownload: Herunterladen
 CorrUploadField: Korrekturen
 CorrUpload: Korrekturen hochladen
 CorrSetCorrector: Korrektor zuweisen
 CorrAutoSetCorrector: Korrekturen verteilen
-NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
+CorrDelete: Abgaben löschen
+NatField name@Text: #{name} muss eine natürliche Zahl sein!
+JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
+SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
 
 SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
+SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
 UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
 NoCorrector: Kein Korrektor
 RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
@@ -245,10 +293,14 @@ RatingComment: Kommentar
 SubmissionUsers: Studenten
 Rating: Korrektur
 RatingPoints: Punkte
+RatingDone: Bewertung sichtbar
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
+PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
+ColumnRatingPoints: Punktzahl
+Pseudonyms: Pseudonyme
 
 FileTitle: Dateiname
 FileModified: Letzte Änderung
@@ -261,6 +313,23 @@ RatingUpdated: Korrektur gespeichert
 RatingDeleted: Korrektur zurückgesetzt
 RatingFilesUpdated: Korrigierte Dateien überschrieben
 
+RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
+RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
+RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
+RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
+RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
+RatingNegative: Bewertungspunkte dürfen nicht negativ sein
+RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
+RatingNotExpected: Keine Bewertungen erlaubt
+RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
+
+SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
+SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
+SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
+SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
+
+MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
+
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 
@@ -274,6 +343,9 @@ DateFormat: Datumsformat
 TimeFormat: Uhrzeitformat
 DownloadFiles: Dateien automatisch herunterladen
 DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
+NotificationSettings: Erwünschte Benachrichtigungen
+
+ActiveAuthTags: Aktivierte Authorisierungsprädikate
 
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
 AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
@@ -289,13 +361,14 @@ SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
 SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
 
 LDAPLoginTitle: Campus-Login
-PWHashLoginTitle: Uni2Work-Login
-PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2Work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an!
+PWHashLoginTitle: Uni2work-Login
+PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an!
 DummyLoginTitle: Development-Login
 
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
+CorrectorStateTip: Abwesende Korrektoren bekommen bei späteren Übungsblättern mehr Korrekturen zum Ausgleich zugewiesen. Entschuldigte Korrektoren müssen nicht nacharbeiten.
 
 DayIsAHoliday     tid@TermId date@Text: #{date} ist ein Feiertag
 DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
@@ -305,7 +378,248 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken
 
+SheetNoSubmissions: Keine Abgabe
+SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
+SheetUserSubmissions: Direkte Abgabe
+
+SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
+
 SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
 
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
+
+MailTestFormEmail: Email-Addresse
+MailTestFormLanguages: Spracheinstellungen
+
+MailTestSubject: Uni2work Test-Email
+MailTestContent: Dies ist eine Test-Email versandt von Uni2work. Von Ihrer Seite ist keine Handlung notwendig.
+MailTestDateTime: Test der Datumsformattierung:
+
+German: Deutsch
+GermanGermany: Deutsch (Deutschland)
+
+MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert
+MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert.
+
+MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
+MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
+
+MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
+MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{tshow n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
+
+MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
+MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
+MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
+MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
+
+MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
+MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
+
+MailEditNotifications: Benachrichtigungen ein-/ausschalten
+MailSubjectSupport: Supportanfrage
+
+SheetGrading: Bewertung
+SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
+SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
+SheetGradingPassBinary:  Bestanden/Nicht Bestanden
+SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
+
+SheetGradingCount': Anzahl
+SheetGradingPoints': Punkte
+SheetGradingPassing': Bestehen
+SheetGradingPassPoints': Bestehen nach Punkten
+SheetGradingPassBinary': Bestanden/Nicht bestanden
+
+SheetTypeBonus grading@SheetGrading: Bonus
+SheetTypeNormal grading@SheetGrading: Normal
+SheetTypeInformational grading@SheetGrading: Keine Wertung
+SheetTypeNotGraded: Unbewertet
+SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information der Teilnehmer.
+SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
+SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
+SummaryTitle: Zusammenfassung über
+SheetGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Blatt" "Blätter"}
+SubmissionGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Abgabe" "Abgaben"}
+
+SheetTypeBonus': Bonus
+SheetTypeNormal': Normal
+SheetTypeInformational': Keine Wertung
+SheetTypeNotGraded': Unbewertet
+
+SheetGradingMaxPoints: Maximalpunktzahl
+SheetGradingPassingPoints: Notwendig zum Bestehen
+
+SheetGroupArbitrary: Arbiträre Gruppen
+SheetGroupRegisteredGroups: Registrierte Gruppen
+SheetGroupNoGroups: Keine Gruppenabgabe
+SheetGroupMaxGroupsize: Maximale Gruppengröße
+
+SheetFiles: Übungsblatt-Dateien
+
+NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
+NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
+NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
+NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
+NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
+NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
+NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
+
+CorrCreate: Abgaben erstellen
+UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
+InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
+InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte.
+PseudonymAutocorrections: Korrekturvorschläge:
+UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}"
+CorrectionPseudonyms: Abgaben-Pseudonyme
+CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile. Kleine Schreibfehler werden u.U. automatisch korrigiert.
+PseudonymSheet: Übungsblatt
+CorrectionPseudonymSheet termDesc@Text csh@CourseShorthand shn@SheetName: #{termDesc} » #{csh} » #{shn}
+SheetGroupTooLarge sheetGroupDesc@Text: Abgabegruppe zu groß: #{sheetGroupDesc}
+SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als Gruppe registriert
+SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen
+SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc})
+SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
+SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
+
+CorrGrade: Korrekturen eintragen
+
+UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
+
+HelpAnswer: Antworten an
+HelpUser: Meinen Benutzeraccount
+HelpAnonymous: Keine Antwort (Anonym)
+HelpEmail: E-Mail
+HelpRequest: Supportanfrage / Verbesserungsvorschlag
+HelpProblemPage: Problematische Seite
+HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
+HelpSent: Ihre Supportanfrage wurde weitergeleitet.
+
+SystemMessageFrom: Sichtbar ab
+SystemMessageTo: Sichtbar bis
+SystemMessageAuthenticatedOnly: Nur angemeldet
+SystemMessageSeverity: Schwere
+SystemMessageId: Id
+SystemMessageSummaryContent: Zusammenfassung / Inhalt
+SystemMessageSummary: Zusammenfassung
+SystemMessageContent: Inhalt
+SystemMessageLanguage: Sprache
+
+SystemMessageDelete: Löschen
+SystemMessageActivate: Sichtbar schalten
+SystemMessageDeactivate: Unsichtbar schalten
+SystemMessageTimestamp: Zeitpunkt
+
+SystemMessagesDeleted: System-Nachrichten gelöscht:
+SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt:
+SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt:
+SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt
+SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId}
+SystemMessageEdit: Statusmeldung anpassen
+SystemMessageEditTranslations: Übersetzungen anpassen
+SystemMessageAddTranslation: Übersetzung hinzufügen
+
+SystemMessageEditSuccess: Statusmeldung angepasst.
+SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt.
+SystemMessageEditTranslationSuccess: Übersetzung angepasst.
+SystemMessageDeleteTranslationSuccess: Übersetzung entfernt.
+
+MessageError: Fehler
+MessageWarning: Warnung
+MessageInfo: Information
+MessageSuccess: Erfolg
+
+InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)
+
+ErrorResponseTitleNotFound: Ressource nicht gefunden
+ErrorResponseTitleInternalError internalError@Text: Ein interner Fehler ist aufgetreten
+ErrorResponseTitleInvalidArgs invalidArgs@Texts: Anfrage-Nachricht enthielt ungültige Argumente
+ErrorResponseTitleNotAuthenticated: Anfrage benötigt Authentifizierung
+ErrorResponseTitlePermissionDenied permissionDenied@Text: Mangelnde Authorisierung
+ErrorResponseTitleBadMethod requestMethod@Method: HTTP-Methode nicht unterstützt
+
+UnknownErrorResponse: Ein nicht weiter klassifizierter Fehler ist aufgetreten:
+ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine Seite gefunden.
+ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden.
+ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt.
+
+ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
+ErrMsgCiphertext: Verschlüsselte Fehlermeldung
+EncodedSecretBoxCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
+EncodedSecretBoxInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
+EncodedSecretBoxInvalidPadding: Verschlüsselte Daten sind nicht korrekt padded
+EncodedSecretBoxCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
+EncodedSecretBoxCouldNotOpenSecretBox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
+EncodedSecretBoxCouldNotDecodePlaintext aesonErr@String: Konnte Klartext nicht JSON-dekodieren: #{aesonErr}
+ErrMsgHeading: Fehlermeldung entschlüsseln
+ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
+
+InvalidRoute: Konnte URL nicht interpretieren
+
+MenuHome: Aktuell
+MenuVersion: Impressum
+MenuHelp: Hilfe
+MenuProfile: Anpassen
+MenuLogin: Login
+MenuLogout: Logout
+MenuCourseList: Kurse
+MenuTermShow: Semester
+MenuSubmissionDelete: Abgabe löschen
+MenuUsers: Benutzer
+MenuAdminTest: Admin-Demo
+MenuMessageList: Systemnachrichten
+MenuAdminErrMsg: Fehlermeldung entschlüsseln
+MenuProfileData: Persönliche Daten
+MenuTermCreate: Neues Semester anlegen
+MenuCourseNew: Neuen Kurs anlegen
+MenuTermEdit: Semester editieren
+MenuCorrection: Korrektur
+MenuCorrections: Korrekturen
+MenuCorrectionsOwn: Meine Korrekturen
+MenuSubmissions: Abgaben
+MenuSheetList: Übungsblätter
+MenuSheetNew: Neues Übungsblatt anlegen
+MenuSheetCurrent: Aktuelles Übungsblatt
+MenuSheetOldUnassigned: Abgaben ohne Korrektor
+MenuCourseEdit: Kurs editieren
+MenuCourseClone: Als neuen Kurs klonen
+MenuCourseDelete: Kurs löschen
+MenuSubmissionNew: Abgabe anlegen
+MenuSubmissionOwn: Abgabe
+MenuCorrectors: Korrektoren
+MenuSheetEdit: Übungsblatt editieren
+MenuSheetDelete: Übungsblatt löschen
+MenuSheetClone:  Als neues Übungsblatt klonen
+MenuCorrectionsUpload: Korrekturen hochladen
+MenuCorrectionsCreate: Abgaben registrieren
+MenuCorrectionsGrade: Abgaben bewerten
+MenuAuthPreds: Authorisierungseinstellungen
+
+AuthPredsActive: Aktive Authorisierungsprädikate
+AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
+AuthTagFree: Seite ist universell zugänglich
+AuthTagAdmin: Nutzer ist Administrator
+AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
+AuthTagDeprecated: Seite ist nicht überholt
+AuthTagDevelopment: Seite ist nicht in Entwicklung
+AuthTagLecturer: Nutzer ist Dozent
+AuthTagCorrector: Nutzer ist Korrektor
+AuthTagTime: Zeitliche Einschränkungen sind erfüllt
+AuthTagRegistered: Nutzer ist Kursteilnehmer
+AuthTagParticipant: Nutzer ist mit Kurs assoziiert
+AuthTagCapacity: Kapazität ist ausreichend
+AuthTagEmpty: Kurs hat keine Teilnehmer
+AuthTagMaterials: Kursmaterialien sind freigegeben
+AuthTagOwner: Nutzer ist Besitzer
+AuthTagRated: Korrektur ist bewertet
+AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
+AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
+AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
+AuthTagRead: Zugriff ist nur lesend
+AuthTagWrite: Zugriff ist i.A. schreibend
+
+DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
+DeleteConfirmation: Bestätigung
+DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
+
+DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde

models

@@ -1,223 +0,0 @@
-User json
-    ident          (CI Text)
-    authentication AuthenticationMode
-    matrikelnummer Text Maybe
-    email          (CI Text)
-    displayName    Text
-    surname        Text            -- always use: nameWidget displayName surname
-    maxFavourites  Int default=12
-    theme          Theme default='Default'
-    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
-    dateFormat     DateTimeFormat "default='%d.%m.%Y'"
-    timeFormat     DateTimeFormat "default='%R'"
-    downloadFiles  Bool default=false
-    UniqueAuthentication ident
-    UniqueEmail email
-    deriving Show
-UserAdmin
-    user   UserId
-    school SchoolId
-    UniqueUserAdmin user school
-UserLecturer
-    user   UserId
-    school SchoolId
-    UniqueSchoolLecturer user school
-StudyFeatures
-    user          UserId
-    degree        StudyDegreeId
-    field         StudyTermsId
-    type          StudyFieldType
-    semester      Int
-    -- UniqueUserSubject user degree field -- There exists a counterexample
-StudyDegree
-    key           Int
-    shorthand     Text Maybe
-    name          Text Maybe
-    Primary key
-StudyTerms
-    key           Int
-    shorthand     Text Maybe
-    name          Text Maybe
-    Primary key
-Term json
-    name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
-    start         Day            -- TermKey   :: TermIdentifier -> TermId
-    end           Day
-    holidays      [Day]
-    lectureStart  Day 
-    lectureEnd    Day 
-    active        Bool    
-    Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
-    deriving Show      -- type TermId = Key Term
-School json
-    name          (CI Text)
-    shorthand     (CI Text)
-    UniqueSchool name
-    UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
-    Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
-    deriving Eq    
-DegreeCourse json
-    course       CourseId
-    degree       StudyDegreeId
-    terms        StudyTermsId
-    UniqueDegreeCourse course degree terms
-Course
-    name             (CI Text)
-    description      Html Maybe
-    linkExternal     Text Maybe
-    shorthand        (CI Text)
-    term             TermId
-    school           SchoolId
-    capacity         Int64 Maybe
-    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
-    registerFrom     UTCTime Maybe
-    registerTo       UTCTime Maybe
-    deregisterUntil  UTCTime Maybe
-    registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
-    materialFree     Bool
-    TermSchoolCourseShort  term school shorthand
-    TermSchoolCourseName   term school name
-CourseEdit
-    user         UserId
-    time         UTCTime
-    course       CourseId
-CourseFavourite
-    user         UserId
-    time         UTCTime
-    course       CourseId
-    UniqueCourseFavourite user course
-    deriving Show
-Lecturer 
-    user         UserId
-    course       CourseId
-    UniqueLecturer user course
-CourseParticipant
-    course          CourseId
-    user            UserId
-    registration    UTCTime
-    UniqueParticipant user course
-Sheet
-    course          CourseId
-    name            (CI Text)
-    description     Html Maybe
-    type            SheetType
-    grouping        SheetGroup
-    markingText     Html Maybe
-    visibleFrom     UTCTime Maybe
-    activeFrom      UTCTime
-    activeTo        UTCTime
-    hintFrom        UTCTime Maybe
-    solutionFrom    UTCTime Maybe
-    uploadMode      UploadMode
-    CourseSheet course name
-SheetEdit
-    user            UserId
-    time            UTCTime
-    sheet           SheetId
-SheetCorrector
-    user            UserId
-    sheet           SheetId
-    load            Load
-    state           CorrectorState default='CorrectorNormal'
-    UniqueSheetCorrector user sheet
-    deriving Show Eq Ord
-SheetFile
-    sheet           SheetId
-    file            FileId
-    type            SheetFileType
-    UniqueSheetFile file sheet type
-File        
-    title           FilePath
-    content         ByteString Maybe -- Nothing iff this is a directory
-    modified        UTCTime
-    deriving Show Eq
-Submission
-    sheet           SheetId
-    ratingPoints    Points  Maybe -- "Just" does not mean done
-    ratingComment   Text    Maybe -- "Just" does not mean done
-    ratingBy        UserId  Maybe -- assigned corrector
-    ratingAssigned  UTCTime Maybe -- time assigned corrector
-    ratingTime      UTCTime Maybe -- "Just" here indicates done!
-    deriving Show
-SubmissionEdit
-    user            UserId
-    time            UTCTime
-    submission      SubmissionId
-SubmissionFile
-    submission      SubmissionId
-    file            FileId
-    isUpdate        Bool         -- is this the file updated by a corrector (original will always be retained)
-    isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
-    UniqueSubmissionFile file submission isUpdate
-    deriving Show
-SubmissionUser                   -- Actual submission participant
-    user            UserId
-    submission      SubmissionId
-    UniqueSubmissionUser user submission
-SubmissionGroup
-    course          CourseId
-    name            Text Maybe
-SubmissionGroupEdit
-    user            UserId
-    time            UTCTime
-    submissionGroup SubmissionGroupId
-SubmissionGroupUser              -- Registered submission groups, independent of actual SubmissionUser
-    submissionGroup     SubmissionGroupId
-    user                UserId
-    UniqueSubmissionGroupUser submissionGroup   user
-Tutorial json
-    name        Text
-    tutor       UserId
-    course      CourseId
-TutorialUser
-    user        UserId
-    tutorial    TutorialId
-    UniqueTutorialUser user   tutorial
-Booking
-    term        TermId
-    begin       UTCTime
-    end         UTCTime
-    weekly      Bool
-    exceptions  [Day]    -- only if weekly, begin in exception
-    bookedFor   RoomForId
-    room        RoomId
-BookingEdit
-    user        UserId
-    time        UTCTime
-    boooking    BookingId
-Room
-    name        Text
-    capacity    Int Maybe
-    building    Text Maybe
--- BookingRoom
---    subject     RoomForId
---    room        RoomId
---    booking     BookingId
---    UniqueRoomCourse subject room   booking
-+RoomFor
-    course      CourseId
-    tutorial    TutorialId
-    exam        ExamId
--- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
--- EXAMS ARE TODO:
-Exam
-    course              CourseId
-    name                Text
-    description         Text
-    begin               UTCTime
-    end                 UTCTime
-    registrationBegin   UTCTime
-    registrationEnd     UTCTime
-    deregistrationEnd   UTCTime
-    ratingVisible       Bool
-    statisticsVisible   Bool
---ExamEdit
---    user                UserId
---    time                UTCTime
---    exam                ExamId
---ExamUser
---    user                UserId
---    examId              ExamId
---    -- CONTINUE HERE: Include rating in this table or separately?
---    UniqueExamUser user   examId
--- By default this file is used in Model.hs (which is imported by Foundation.hs)

models/config

@@ -0,0 +1,4 @@
+ClusterConfig
+    setting             ClusterSettingsKey
+    value               Value
+    Primary setting

models/courses

@@ -0,0 +1,50 @@
+DegreeCourse json
+    course       CourseId
+    degree       StudyDegreeId
+    terms        StudyTermsId
+    UniqueDegreeCourse course degree terms
+Course
+    name             (CI Text)
+    description      Html Maybe
+    linkExternal     Text Maybe
+    shorthand        (CI Text)
+    term             TermId
+    school           SchoolId
+    capacity         Int64 Maybe
+    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+    registerFrom     UTCTime Maybe
+    registerTo       UTCTime Maybe
+    deregisterUntil  UTCTime Maybe
+    registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
+    materialFree     Bool
+    TermSchoolCourseShort  term school shorthand
+    TermSchoolCourseName   term school name
+    deriving Generic
+CourseEdit
+    user         UserId
+    time         UTCTime
+    course       CourseId
+CourseFavourite
+    user         UserId
+    time         UTCTime
+    course       CourseId
+    UniqueCourseFavourite user course
+    deriving Show
+Lecturer
+    user         UserId
+    course       CourseId
+    UniqueLecturer user course
+CourseParticipant
+    course       CourseId
+    user         UserId
+    registration UTCTime
+    UniqueParticipant user course
+CourseUserNote
+    course       CourseId
+    user         UserId
+    note         Text
+    UniqueCourseUserNotes user course
+CourseUserNoteEdit
+    user         UserId
+    time         UTCTime
+    note         CourseUserNoteId

models/exams

@@ -0,0 +1,22 @@
+-- EXAMS ARE TODO:
+Exam
+    course              CourseId
+    name                Text
+    description         Text
+    begin               UTCTime
+    end                 UTCTime
+    registrationBegin   UTCTime
+    registrationEnd     UTCTime
+    deregistrationEnd   UTCTime
+    ratingVisible       Bool
+    statisticsVisible   Bool
+--ExamEdit
+--    user                UserId
+--    time                UTCTime
+--    exam                ExamId
+--ExamUser
+--    user                UserId
+--    examId              ExamId
+--    -- CONTINUE HERE: Include rating in this table or separately?
+--    UniqueExamUser user   examId
+-- By default this file is used in Model.hs (which is imported by Foundation.hs)

models/files

@@ -0,0 +1,5 @@
+File
+    title           FilePath
+    content         ByteString Maybe -- Nothing iff this is a directory
+    modified        UTCTime
+    deriving Show Eq Generic

models/jobs

@@ -0,0 +1,12 @@
+QueuedJob
+    content             Value
+    creationInstance    InstanceId
+    creationTime        UTCTime
+    lockInstance        InstanceId Maybe
+    lockTime            UTCTime Maybe
+    deriving Eq Read Show Generic Typeable
+CronLastExec
+    job                 Value
+    time                UTCTime
+    instance            InstanceId
+    UniqueCronLastExec job

models/rooms

@@ -0,0 +1,26 @@
+Booking
+    term        TermId
+    begin       UTCTime
+    end         UTCTime
+    weekly      Bool
+    exceptions  [Day]    -- only if weekly, begin in exception
+    bookedFor   RoomForId
+    room        RoomId
+BookingEdit
+    user        UserId
+    time        UTCTime
+    boooking    BookingId
+Room
+    name        Text
+    capacity    Int Maybe
+    building    Text Maybe
+-- BookingRoom
+--    subject     RoomForId
+--    room        RoomId
+--    booking     BookingId
+--    UniqueRoomCourse subject room   booking
++RoomFor
+    course      CourseId
+    tutorial    TutorialId
+    exam        ExamId
+-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...

models/schools

@@ -0,0 +1,7 @@
+School json
+    name          (CI Text)
+    shorthand     (CI Text)
+    UniqueSchool name
+    UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
+    Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
+    deriving Eq Show Generic

models/sheets

@@ -0,0 +1,39 @@
+Sheet
+    course          CourseId
+    name            (CI Text)
+    description     Html Maybe
+    type            SheetType
+    grouping        SheetGroup
+    markingText     Html Maybe
+    visibleFrom     UTCTime Maybe
+    activeFrom      UTCTime
+    activeTo        UTCTime
+    hintFrom        UTCTime Maybe
+    solutionFrom    UTCTime Maybe
+    uploadMode      UploadMode
+    submissionMode  SheetSubmissionMode default='UserSubmissions'
+    autoDistribute  Bool default=false
+    CourseSheet course name
+    deriving Generic
+SheetEdit
+    user            UserId
+    time            UTCTime
+    sheet           SheetId
+SheetPseudonym
+    sheet           SheetId
+    pseudonym       Pseudonym
+    user            UserId
+    UniqueSheetPseudonym sheet pseudonym
+    UniqueSheetPseudonymUser sheet user
+SheetCorrector
+    user            UserId
+    sheet           SheetId
+    load            Load
+    state           CorrectorState default='CorrectorNormal'
+    UniqueSheetCorrector user sheet
+    deriving Show Eq Ord
+SheetFile
+    sheet           SheetId
+    file            FileId
+    type            SheetFileType
+    UniqueSheetFile file sheet type

models/submissions

@@ -0,0 +1,34 @@
+Submission
+    sheet           SheetId
+    ratingPoints    Points  Maybe -- "Just" does not mean done
+    ratingComment   Text    Maybe -- "Just" does not mean done
+    ratingBy        UserId  Maybe -- assigned corrector
+    ratingAssigned  UTCTime Maybe -- time assigned corrector
+    ratingTime      UTCTime Maybe -- "Just" here indicates done!
+    deriving Show Generic
+SubmissionEdit
+    user            UserId
+    time            UTCTime
+    submission      SubmissionId
+SubmissionFile
+    submission      SubmissionId
+    file            FileId
+    isUpdate        Bool         -- is this the file updated by a corrector (original will always be retained)
+    isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
+    UniqueSubmissionFile file submission isUpdate
+    deriving Show
+SubmissionUser                   -- Actual submission participant
+    user            UserId
+    submission      SubmissionId
+    UniqueSubmissionUser user submission
+SubmissionGroup
+    course          CourseId
+    name            Text Maybe
+SubmissionGroupEdit
+    user            UserId
+    time            UTCTime
+    submissionGroup SubmissionGroupId
+SubmissionGroupUser              -- Registered submission groups, independent of actual SubmissionUser
+    submissionGroup     SubmissionGroupId
+    user                UserId
+    UniqueSubmissionGroupUser submissionGroup   user

models/system-messages

@@ -0,0 +1,14 @@
+SystemMessage
+    from                UTCTime Maybe
+    to                  UTCTime Maybe
+    authenticatedOnly   Bool
+    severity            MessageClass
+    defaultLanguage     Lang
+    content             Html
+    summary             Html Maybe
+SystemMessageTranslation
+    message             SystemMessageId
+    language            Lang
+    content             Html
+    summary             Html Maybe
+    UniqueSystemMessageTranslation message language

models/terms

@@ -0,0 +1,10 @@
+Term json
+    name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
+    start         Day            -- TermKey   :: TermIdentifier -> TermId
+    end           Day
+    holidays      [Day]
+    lectureStart  Day
+    lectureEnd    Day
+    active        Bool
+    Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
+    deriving Show Eq Generic -- type TermId = Key Term

models/tutorials

@@ -0,0 +1,8 @@
+Tutorial json
+    name        Text
+    tutor       UserId
+    course      CourseId
+TutorialUser
+    user        UserId
+    tutorial    TutorialId
+    UniqueTutorialUser user   tutorial

models/users

@@ -0,0 +1,43 @@
+User json
+    ident          (CI Text)
+    authentication AuthenticationMode
+    matrikelnummer Text Maybe
+    email          (CI Text)
+    displayName    Text
+    surname        Text            -- always use: nameWidget displayName surname
+    maxFavourites  Int default=12
+    theme          Theme default='Default'
+    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
+    dateFormat     DateTimeFormat "default='%d.%m.%Y'"
+    timeFormat     DateTimeFormat "default='%R'"
+    downloadFiles  Bool default=false
+    mailLanguages  MailLanguages default='[]'
+    notificationSettings NotificationSettings
+    UniqueAuthentication ident
+    UniqueEmail email
+    deriving Show Eq Generic
+UserAdmin
+    user   UserId
+    school SchoolId
+    UniqueUserAdmin user school
+UserLecturer
+    user   UserId
+    school SchoolId
+    UniqueSchoolLecturer user school
+StudyFeatures
+    user          UserId
+    degree        StudyDegreeId
+    field         StudyTermsId
+    type          StudyFieldType
+    semester      Int
+    -- UniqueUserSubject user degree field -- There exists a counterexample
+StudyDegree
+    key           Int
+    shorthand     Text Maybe
+    name          Text Maybe
+    Primary key
+StudyTerms
+    key           Int
+    shorthand     Text Maybe
+    name          Text Maybe
+    Primary key

package.yaml

@@ -2,115 +2,195 @@ name:    uniworx
 version: "0.0.0"
 
 dependencies:
+  # Due to a bug in GHC 8.0.1, we block its usage
+  # See: https://ghc.haskell.org/trac/ghc/ticket/12130
+  - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+  # version 1.0 had a bug in reexporting Handler, causing trouble
+  - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
+  - foreign-store
+  - yesod >=1.4.3 && <1.5
+  - yesod-core >=1.4.30 && <1.5
+  - yesod-auth >=1.4.0 && <1.5
+  - yesod-static >=1.4.0.3 && <1.6
+  - 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-postgresql >=2.1.1 && <2.8
+  - persistent-template >=2.0 && <2.8
+  - 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
+  - http-conduit >=2.1 && <2.3
+  - directory >=1.1 && <1.4
+  - warp >=3.0 && <3.3
+  - data-default
+  - aeson >=0.6 && <1.3
+  - conduit >=1.0 && <2.0
+  - monad-logger >=0.3 && <0.4
+  - fast-logger >=2.2 && <2.5
+  - wai-logger >=2.2 && <2.4
+  - file-embed
+  - safe
+  - unordered-containers
+  - containers
+  - vector
+  - time
+  - case-insensitive
+  - wai
+  - cryptonite
+  - cryptonite-conduit
+  - saltine
+  - base64-bytestring
+  - memory
+  - http-api-data
+  - profunctors
+  - colonnade >=1.1.1
+  - yesod-colonnade >=1.1.0
+  - blaze-markup
+  - zip-stream
+  - filepath
+  - transformers
+  - wl-pprint-text
+  - uuid-types
+  - path-pieces
+  - uuid-crypto
+  - filepath-crypto
+  - cryptoids-types
+  - cryptoids
+  - cryptoids-class
+  - binary
+  - cereal
+  - mtl
+  - sandi
+  - esqueleto
+  - mime-types
+  - generic-deriving
+  - blaze-html
+  - conduit-resumablesink >=0.2
+  - parsec
+  - uuid
+  - exceptions
+  - stm
+  - stm-chans
+  - stm-conduit
+  - lens
+  - MonadRandom
+  - email-validate
+  - scientific
+  - tz
+  - system-locale
+  - th-lift-instances
+  - gitrev
+  - Glob
+  - ldap-client
+  - connection
+  - universe
+  - universe-base
+  - random
+  - random-shuffle
+  - th-abstraction
+  - HaskellNet
+  - HaskellNet-SSL
+  - network
+  - resource-pool
+  - mime-mail
+  - hashable
+  - aeson-pretty
+  - resourcet
+  - postgresql-simple
+  - word24
+  - mmorph
+  - clientsession
+  - monad-memo
+  - xss-sanitize
+  - text-metrics
+  - pkcs7
+  - memcached-binary
+  - directory-tree
+  - lifted-base
 
-# Due to a bug in GHC 8.0.1, we block its usage
-# See: https://ghc.haskell.org/trac/ghc/ticket/12130
-- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+other-extensions:
+  - GeneralizedNewtypeDeriving
+  - IncoherentInstances
+  - OverloadedLists
+  - UndecidableInstances
 
-# version 1.0 had a bug in reexporting Handler, causing trouble
-- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
+default-extensions:
+  - OverloadedStrings
+  - PartialTypeSignatures
+  - ScopedTypeVariables
+  - TemplateHaskell
+  - QuasiQuotes
+  - CPP
+  - TypeSynonymInstances
+  - KindSignatures
+  - ConstraintKinds
+  - ViewPatterns
+  - TypeOperators
+  - TupleSections
+  - TypeFamilies
+  - GADTs
+  - StandaloneDeriving
+  - RecordWildCards
+  - RankNTypes
+  - PatternGuards
+  - PatternSynonyms
+  - ParallelListComp
+  - NumDecimals
+  - MultiWayIf
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - LambdaCase
+  - MultiParamTypeClasses
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - EmptyDataDecls
+  - ExistentialQuantification
+  - DefaultSignatures
+  - DeriveDataTypeable
+  - DeriveGeneric
+  - DeriveLift
+  - DeriveFunctor
+  - DerivingStrategies
+  - DataKinds
+  - BinaryLiterals
+  - PolyKinds
+  - PackageImports
+  - TypeApplications
+  - RecursiveDo
 
-- foreign-store
-- yesod >=1.4.3 && <1.5
-- yesod-core >=1.4.30 && <1.5
-- yesod-auth >=1.4.0 && <1.5
-- yesod-static >=1.4.0.3 && <1.6
-- 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-postgresql >=2.1.1 && <2.8
-- persistent-template >=2.0 && <2.8
-- 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
-- http-conduit >=2.1 && <2.3
-- directory >=1.1 && <1.4
-- warp >=3.0 && <3.3
-- data-default
-- aeson >=0.6 && <1.3
-- conduit >=1.0 && <2.0
-- monad-logger >=0.3 && <0.4
-- fast-logger >=2.2 && <2.5
-- wai-logger >=2.2 && <2.4
-- file-embed
-- safe
-- unordered-containers
-- containers
-- vector
-- time
-- case-insensitive
-- wai
-- cryptonite
-- cryptonite-conduit
-- base64-bytestring
-- memory
-- http-api-data
-- profunctors
-- colonnade >=1.1.1
-- yesod-colonnade >=1.1.0
-- blaze-markup
-- zip-stream
-- filepath
-- transformers
-- wl-pprint-text
-- uuid-types
-- path-pieces
-- uuid-crypto
-- filepath-crypto
-- cryptoids-types
-- cryptoids
-- cryptoids-class
-- binary
-- mtl
-- sandi
-- esqueleto
-- mime-types
-- generic-deriving
-- blaze-html
-- conduit-resumablesink >=0.2
-- parsec
-- uuid
-- exceptions
-- lens
-- MonadRandom
-- email-validate
-- scientific
-- tz
-- system-locale
-- th-lift-instances
-- gitrev
-- Glob
-- ldap-client
-- connection
-- universe
-- universe-base
-- random-shuffle
-- th-abstraction
+ghc-options:
+  - -Wall
+  - -fno-warn-type-defaults
+  - -fno-warn-partial-type-signatures
+
+when:
+  - condition: flag(pedantic)
+    ghc-options:
+      - -Werror
+      - -fwarn-tabs
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
 library:
   source-dirs: src
   when:
-  - condition: (flag(dev)) || (flag(library-only))
-    then:
-      ghc-options:
-      - -Wall
-      - -fwarn-tabs
-      - -O0
-      - -ddump-splices
-      cpp-options: -DDEVELOPMENT
-    else:
-      ghc-options:
-      - -Wall
-      - -fwarn-tabs
-      - -O2
+    - condition: (flag(dev)) || (flag(library-only))
+      then:
+        ghc-options:
+          - -O0
+          - -ddump-splices
+        cpp-options: -DDEVELOPMENT
+      else:
+        ghc-options:
+          - -O2
 
 # Runnable executable for our application
 executables:
@@ -118,28 +198,52 @@ executables:
     main: main.hs
     source-dirs: app
     ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
     dependencies:
-    - uniworx
+      - uniworx
     when:
-    - condition: flag(library-only)
-      buildable: false
+      - condition: flag(library-only)
+        buildable: false
+  uniworxdb:
+    main: Database.hs
+    ghc-options:
+      - -main-is Database
+    source-dirs: test
+    dependencies:
+      - uniworx
+    other-modules: []
 
 # Test suite
 tests:
-  test:
-    main: Spec.hs
+  yesod:
+    main: Main.hs
     source-dirs: test
-    ghc-options: -Wall
     dependencies:
-    - uniworx
-    - hspec >=2.0.0
-    - QuickCheck
-    - yesod-test
-    - conduit-extra
-    - quickcheck-instances
+      - uniworx
+      - hspec >=2.0.0
+      - QuickCheck
+      - yesod-test
+      - conduit-extra
+      - quickcheck-classes
+      - quickcheck-instances
+      - generic-arbitrary
+      - http-types
+    ghc-options:
+      - -fno-warn-orphans
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+  hlint:
+    main: Hlint.hs
+    other-modules: []
+    source-dirs: hlint
+    dependencies:
+      - hlint-test
+    when:
+      - condition: "!flag(pedantic)"
+        buildable: false
 
 # Define flags used by "yesod devel" to make compilation faster
 flags:
@@ -151,3 +255,7 @@ flags:
     description: Turn on development settings, like auto-reload templates.
     manual: false
     default: false
+  pedantic:
+    description: Be very pedantic about warnings and errors
+    manual: false
+    default: true

routes

@@ -10,36 +10,42 @@
 --  Admins always have access to entities within their assigned schools.
 --
 --  Access Tags:
---    !free       -- free for all
---    !lecturer   -- lecturer    for this course (or the school, if route is not connected to a course)
---    !corrector  -- corrector   for this sheet  (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
---    !registered -- participant for this course (no effect outside of courses)
---    !owner      -- part of the group of owners of this submission
---    !capacity   -- course this route is associated with has at least one unit of participant capacity
+--    !free        -- free for all
+--    !lecturer    -- lecturer    for this course (or the school, if route is not connected to a course)
+--    !corrector   -- corrector   for this sheet  (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
+--    !registered  -- participant for this course (no effect outside of courses)
+--    !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
+--    !owner       -- part of the group of owners of this submission
+--    !capacity    -- course this route is associated with has at least one unit of participant capacity
+--    !empty       -- course this route is associated with has no participants whatsoever
 --
---    !materials  -- only if course allows all materials to be free (no meaning outside of courses)
---    !time       -- access depends on time somehow
---    !isRead     -- only if it is read-only access (i.e. GET but not POST)
---    !isWrite    -- only if it is write access     (i.e. POST only) why needed???
---
---    !deprecated -- like free, but logs and gives a warning; entirely disabled in production
+--    !materials   -- only if course allows all materials to be free (no meaning outside of courses)
+--    !time        -- access depends on time somehow
+--    !read        -- only if it is read-only access (i.e. GET but not POST)
+--    !write       -- only if it is write access     (i.e. POST only, included for completeness)
 --
+--    !deprecated  -- like free, but logs and gives a warning; entirely disabled in production
+--    !development -- like free, but only for development builds
 
-/static StaticR Static appStatic                              !free
+/static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
 /favicon.ico FaviconR GET                                     !free
 /robots.txt RobotsR GET                                       !free
 
-/                           HomeR             GET             !free
-/users                      UsersR            GET             -- no tags, i.e. admins only
-/admin/test                 AdminTestR        GET POST
-/admin/user/#CryptoUUIDUser AdminUserR        GET
-/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
-/info                       VersionR          GET             !free
+/                             HomeR             GET           !free
+/users                        UsersR            GET           -- no tags, i.e. admins only
+/users/#CryptoUUIDUser        AdminUserR        GET           !development
+/users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
+/admin/test                   AdminTestR        GET POST
+/admin/errMsg                 AdminErrMsgR      GET POST
+/info                         VersionR          GET            !free
+/help                         HelpR             GET POST       !free
 
-/profile                    ProfileR          GET POST        !free                             !free
-/profile/data               ProfileDataR      GET POST        !free                             !free
+/profile                    ProfileR          GET POST         !free
+/profile/data               ProfileDataR      GET POST         !free
+
+/authpreds                  AuthPredsR        GET POST         !free
 
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
@@ -48,43 +54,54 @@
 !/term/#TermId             TermCourseListR   GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET             !free
 
-/school                    SchoolListR       GET
-/school/#SchoolId          SchoolShowR       GET
+/school                    SchoolListR       GET             !development
+/school/#SchoolId          SchoolShowR       GET             !development
 
 
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
-!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand}   CourseNewTemplateR GET   !lecturer
 /course/#TermId/#SchoolId/#CourseShorthand CourseR          !lecturer:
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET
-  /user/#CryptoUUIDUser       CUserR          GET
+  /users/#CryptoUUIDUser      CUserR          GET             !lecturerANDparticipant
   /correctors                 CHiWisR         GET
+  /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST
-  /ex                         SheetListR      GET             !registered !materials
-  !/ex/new                    SheetNewR       GET POST
+  /ex                         SheetListR      GET             !registered !materials !corrector
+  /ex/new                     SheetNewR       GET POST
+  /ex/current                 SheetCurrentR   GET             !registered !materials !corrector
+  /ex/unassigned              SheetOldUnassigned GET
   /ex/#SheetName SheetR:
-    /                           SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
+    /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
     /edit                       SEditR        GET POST
     /delete                     SDelR         GET POST
     /subs                       SSubsR        GET POST        -- for lecturer only
-    /subs/new                   SubmissionNewR GET POST        !timeANDregistered
-    /subs/own                   SubmissionOwnR GET             !free -- just redirect
-    /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
-      /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
-      /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner
-      /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
-      !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
+    !/subs/new                  SubmissionNewR GET POST       !timeANDregisteredANDuser-submissions
+    !/subs/own                  SubmissionOwnR GET            !free -- just redirect
+    /subs/#CryptoFileNameSubmission SubmissionR:
+      /                         SubShowR      GET POST        !ownerANDtime !ownerANDread !correctorANDread
+      /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner !corrector
+      /delete                   SubDelR       GET POST        !ownerANDtime
+      /assign                   SAssignR      GET POST	      !lecturerANDtime
+      /correction               CorrectionR   GET POST        !corrector !ownerANDreadANDrated
+      !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner !corrector
     /correctors                 SCorrR        GET POST
+    /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 
-/corrections  CorrectionsR GET POST !corrector !lecturer
-/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+/subs  CorrectionsR GET POST !corrector !lecturer
+/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
+/subs/create CorrectionsCreateR GET POST !corrector !lecturer
+/subs/grade CorrectionsGradeR GET POST !corrector !lecturer
+
+
+/msgs                           MessageListR GET POST
+/msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDreadANDauthentication
 
 
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect

shell.nix

@@ -22,7 +22,7 @@ let
   '';
 
   override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 

src/Application.hs

@@ -1,11 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Application
     ( getApplicationDev, getAppDevSettings
     , appMain
@@ -13,6 +7,7 @@ module Application
     , makeFoundation
     , makeLogWare
     -- * for DevelMain
+    , foundationStoreNum
     , getApplicationRepl
     , shutdownApp
     -- * for GHCI
@@ -21,7 +16,7 @@ module Application
     , addPWEntry
     ) where
 
-import Control.Monad.Logger                 (liftLoc, runLoggingT)
+import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
 import Import
@@ -35,15 +30,48 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                              IPAddrSource (..),
                                              OutputFormat (..), destination,
                                              mkRequestLogger, outputFormat)
-import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
-                                             toLogStr)
+import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
+                                            , toLogStr, rmLoggerSet
+                                            )
+
+import qualified Data.Map.Strict as Map
+
+import Foreign.Store
+
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import System.Directory
+import System.FilePath
+
+import Jobs
 
 import qualified Data.Text.Encoding as Text
 import Yesod.Auth.Util.PasswordStore
 
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Yaml as Yaml
+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 Control.Monad.Trans.Resource
+
+import System.Log.FastLogger.Date
+import qualified Yesod.Core.Types as Yesod (Logger(..))
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Control.Lens
+
+import Data.Proxy
+
+import qualified Data.Aeson as Aeson
+
+import System.Exit (exitFailure)
+
+import qualified Database.Memcached.Binary.IO as Memcached
+  
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -58,6 +86,7 @@ import Handler.Sheet
 import Handler.Submission
 import Handler.Corrections
 import Handler.CryptoIDDispatch
+import Handler.SystemMessage
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half
@@ -69,100 +98,229 @@ 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 :: AppSettings -> IO UniWorX
-makeFoundation appSettings@(AppSettings{..}) = do
+makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
+makeFoundation appSettings@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
-    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
-    appStatic <-
-        (if appMutableStatic then staticDevel else static)
-        appStaticDir
+    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
 
-    appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
+    let
+      mkLogger LogSettings{..} = do
+        tgetter <- newTimeCache "%Y-%m-%d %T %z"
+        loggerSet <- case logDestination of
+          LogDestStderr -> newStderrLoggerSet defaultBufSize
+          LogDestStdout -> newStdoutLoggerSet defaultBufSize
+          LogDestFile{..} -> newFileLoggerSet defaultBufSize logDestFile
+        return $ Yesod.Logger loggerSet tgetter
+      mkLogger' = liftIO $ do
+        initialSettings <- readTVarIO appLogSettings
+        tVar <- newTVarIO =<< mkLogger initialSettings
+        let updateLogger prevSettings = do
+              newSettings <- atomically $ do
+                newSettings <- readTVar appLogSettings
+                guard $ newSettings /= prevSettings
+                return newSettings
+              oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
+              rmLoggerSet $ loggerSet oldLogger
+              updateLogger newSettings
+        (tVar, ) <$> fork (updateLogger initialSettings)
+    appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
+
+    let appStatic = embeddedStatic
+
+    appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
+
+    appJobCtl <- liftIO $ newTVarIO Map.empty
+    appCronThread <- liftIO newEmptyTMVarIO
 
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-        tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
-        logFunc = messageLoggerSource tempFoundation appLogger
+        tempFoundation = mkFoundation
+          (error "connPool forced in tempFoundation")
+          (error "smtpPool forced in tempFoundation")
+          (error "ldapPool forced in tempFoundation")
+          (error "cryptoIDKey forced in tempFoundation")
+          (error "sessionKey forced in tempFoundation")
+          (error "secretBoxKey forced in tempFoundation")
+          (error "widgetMemcached forced in tempFoundation")
+        logFunc loc src lvl str = do
+          f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
+          f loc src lvl str
 
-    -- Create the database connection pool
-    pool <- flip runLoggingT logFunc $ createPostgresqlPool
+    flip runLoggingT logFunc $ do
+      $logDebugS "InstanceID" $ UUID.toText appInstanceID
+      -- logDebugS "Configuration" $ tshow appSettings
+
+      smtpPool <- traverse createSmtpPool appSmtpConf
+
+      appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf
+
+      -- Create the database connection pool
+      sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-    -- Perform database migration using our application's logging settings.
-    runLoggingT (runSqlPool migrateAll pool) logFunc
+      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+    
+      -- Perform database migration using our application's logging settings.
+      migrateAll `runSqlPool` sqlPool
+      appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
+      appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
+      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
 
-    -- Return the foundation
-    return $ mkFoundation pool
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
+
+      handleJobs foundation
+
+      -- Return the foundation
+      return foundation
+
+clusterSetting :: forall key m p.
+                  ( MonadIO m
+                  , ClusterSetting key
+                  , MonadLogger m
+                  )
+               => p (key :: ClusterSettingsKey)
+               -> ReaderT SqlBackend m (ClusterSettingValue key)
+clusterSetting proxy@(knownClusterSetting -> key) = do
+  current' <- get (ClusterConfigKey key)
+  case Aeson.fromJSON . clusterConfigValue <$> current' of
+    Just (Aeson.Success c) -> return c
+    Just (Aeson.Error str) -> do
+      $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key <> ": " <> pack str
+      liftIO exitFailure
+    Nothing -> do
+      new <- initClusterSetting proxy
+      void . insert $ ClusterConfig key (Aeson.toJSON new)
+      return new
+  
+readInstanceIDFile :: MonadIO m => FilePath -> m UUID
+readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
+  where
+    parseBS :: LBS.ByteString -> IO UUID
+    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
+    generateInstead :: IOException -> IO UUID
+    generateInstead e
+      | isDoesNotExistError e = do
+          createDirectoryIfMissing True $ takeDirectory idFile
+          instanceId <- UUID.nextRandom
+          LBS.writeFile idFile $ UUID.toByteString instanceId
+          return instanceId
+      | otherwise = throw e
+
+createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
+createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
+  logFunc <- askLoggerIO
+  let
+    withLogging :: LoggingT IO a -> IO a
+    withLogging = flip runLoggingT logFunc
+    
+    mkConnection = withLogging $ do
+      $logInfoS "SMTP" "Opening new connection"
+      liftIO mkConnection'
+    mkConnection'
+      | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
+      | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
+      | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
+    reapConnection conn = withLogging $ do
+      $logDebugS "SMTP" "Closing connection"
+      liftIO $ closeSMTP conn
+    applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
+    applyAuth SmtpAuthConf{..} conn = withLogging $ do
+      $logDebugS "SMTP" "Doing authentication"
+      authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
+      unless authSuccess $
+        fail "SMTP authentication failed"
+      return conn
+  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
+
+createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
+createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
-makeApplication :: UniWorX -> IO Application
-makeApplication foundation = do
+makeApplication :: MonadIO m => UniWorX -> m Application
+makeApplication foundation = liftIO $ do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
     return $ logWare $ defaultMiddlewaresNoLogging appPlain
 
-makeLogWare :: UniWorX -> IO Middleware
-makeLogWare foundation =
-    mkRequestLogger def
-        { outputFormat =
-            if appDetailedRequestLogging $ appSettings foundation
-                then Detailed True
-                else Apache
-                        (if appIpFromHeader $ appSettings foundation
-                            then FromFallback
-                            else FromSocket)
-        , destination = Logger $ loggerSet $ appLogger foundation
-        }
+makeLogWare :: MonadIO m => UniWorX -> m Middleware
+makeLogWare app = do
+  logWareMap <- liftIO $ newTVarIO HashMap.empty
 
+  let
+    mkLogWare ls@LogSettings{..} = do
+      logger <- readTVarIO . snd $ appLogger app
+      logWare <- mkRequestLogger def
+        { outputFormat = bool
+            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Detailed True)
+            logDetailed
+        , destination = Logger $ loggerSet logger
+        }
+      atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
+      return logWare
+
+  void. liftIO $
+    mkLogWare =<< readTVarIO (appLogSettings app)
+
+  return $ \wai req fin -> do
+    lookupRes <- atomically $ do
+      ls <- readTVar $ appLogSettings app
+      existing <- HashMap.lookup ls <$> readTVar logWareMap
+      return $ maybe (Left ls) Right existing
+    logWare <- either mkLogWare return lookupRes
+    logWare wai req fin
 
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
-warpSettings foundation =
-      setPort (appPort $ appSettings foundation)
-    $ setHost (appHost $ appSettings foundation)
-    $ setOnException (\_req e ->
-        when (defaultShouldDisplayException e) $ messageLoggerSource
+warpSettings foundation = defaultSettings
+    & setPort (appPort $ appSettings foundation)
+    & setHost (appHost $ appSettings foundation)
+    & setOnException (\_req e ->
+        when (defaultShouldDisplayException e) $ do
+          logger <- readTVarIO . snd $ appLogger foundation
+          messageLoggerSource
             foundation
-            (appLogger foundation)
+            logger
             $(qLocation >>= liftLoc)
             "yesod"
             LevelError
             (toLogStr $ "Exception from Warp: " ++ show e))
-      defaultSettings
 
 -- | For yesod devel, return the Warp settings and WAI Application.
-getApplicationDev :: IO (Settings, Application)
+getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
 getApplicationDev = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
+    wsettings <- liftIO . getDevSettings $ warpSettings foundation
     app <- makeApplication foundation
     return (wsettings, app)
 
-getAppDevSettings :: IO AppSettings
-getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+getAppDevSettings :: MonadIO m => m AppSettings
+getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
 
 -- | main function for use by yesod devel
 develMain :: IO ()
-develMain = develMainHelper getApplicationDev
+develMain = runResourceT $
+  liftIO . develMainHelper . return =<< getApplicationDev
 
 -- | The @main@ function for an executable running this site.
-appMain :: IO ()
-appMain = do
+appMain :: MonadResourceBase m => m ()
+appMain = runResourceT $ do
     -- Get the settings from all relevant sources
-    settings <- loadYamlSettingsArgs
+    settings <- liftIO $
+      loadYamlSettingsArgs
         -- fall back to compile-time values, set to [] to require values at runtime
         [configSettingsYmlValue]
 
@@ -176,22 +334,36 @@ appMain = do
     app <- makeApplication foundation
 
     -- Run the application with Warp
-    runSettings (warpSettings foundation) app
+    liftIO $ runSettings (warpSettings foundation) app
 
 
 --------------------------------------------------------------
 -- Functions for DevelMain.hs (a way to run the app from GHCi)
 --------------------------------------------------------------
-getApplicationRepl :: IO (Int, UniWorX, Application)
+foundationStoreNum :: Word32
+foundationStoreNum = 2
+  
+getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
 getApplicationRepl = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
+    wsettings <- liftIO . getDevSettings $ warpSettings foundation
     app1 <- makeApplication foundation
+
+    let foundationStore = Store foundationStoreNum
+    liftIO $ deleteStore foundationStore
+    liftIO $ writeStore foundationStore foundation
+  
     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: UniWorX -> IO ()
-shutdownApp _ = return ()
+shutdownApp :: MonadIO m => UniWorX -> m ()
+shutdownApp app = do
+  stopJobCtl app
+  liftIO $ do
+    for_ (appWidgetMemcached app) Memcached.close
+    for_ (appSmtpPool app) destroyAllResources
+    destroyAllResources $ appConnPool app
+  release . fst $ appLogger app
 
 
 ---------------------------------------------
@@ -200,7 +372,7 @@ shutdownApp _ = return ()
 
 -- | Run a handler
 handler :: Handler a -> IO a
-handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
+handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
 
 -- | Run DB queries
 db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
@@ -209,7 +381,7 @@ db = handler . runDB
 addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
+addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
   PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
   (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Auth/Dummy.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , FlexibleContexts
-           , TypeFamilies
-           , OverloadedStrings
-  #-}
-
 module Auth.Dummy
   ( dummyLogin
   , DummyMessage(..)
@@ -21,14 +13,15 @@ import qualified Data.CaseInsensitive as CI
 
 
 data DummyMessage = MsgDummyIdent
+                  | MsgDummyNoFormData
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
 dummyForm :: ( RenderMessage site FormMessage
              , RenderMessage site DummyMessage
              , YesodPersist site
              , SqlBackendCanRead (YesodPersistBackend site)
-             , Button site SubmitButton
-             , Show (ButtonCssClass site)
+             , Button site ButtonSubmit
              ) => AForm (HandlerT site IO) (CI Text)
 dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
          <* submitButton
@@ -41,8 +34,7 @@ dummyLogin :: ( YesodAuth site
               , SqlBackendCanRead (YesodPersistBackend site)
               , RenderMessage site FormMessage
               , RenderMessage site DummyMessage
-              , Button site SubmitButton
-              , Show (ButtonCssClass site)
+              , Button site ButtonSubmit
               ) => AuthPlugin site
 dummyLogin = AuthPlugin{..}
   where
@@ -54,7 +46,9 @@ dummyLogin = AuthPlugin{..}
         FormFailure errs -> do
           lift . forM_ errs $ addMessage Error . toHtml
           redirect LoginR
-        FormMissing -> redirect LoginR
+        FormMissing -> do
+          lift $ addMessageI Warning MsgDummyNoFormData
+          redirect LoginR
         FormSuccess ident ->
           lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
     apDispatch _ _ = notFound

src/Auth/LDAP.hs

@@ -1,14 +1,3 @@
-{-# LANGUAGE RecordWildCards
-           , OverloadedStrings
-           , TemplateHaskell
-           , ViewPatterns
-           , TypeFamilies
-           , FlexibleContexts
-           , FlexibleInstances
-           , NoImplicitPrelude
-           , ScopedTypeVariables
-  #-}
-
 module Auth.LDAP
   ( campusLogin
   , CampusUserException(..)
@@ -28,6 +17,7 @@ import qualified Control.Monad.Catch as Exc
 
 import Utils.Form
 
+import Ldap.Client (Ldap)
 import qualified Ldap.Client as Ldap
 
 import qualified Data.Text.Encoding as Text
@@ -38,23 +28,24 @@ import qualified Yesod.Auth.Message as Msg
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
   , campusPassword :: Text
-  }
+  } deriving (Generic, Typeable)
 
 data CampusMessage = MsgCampusIdentNote
                    | MsgCampusIdent
                    | MsgCampusPassword
                    | MsgCampusSubmit
                    | MsgCampusInvalidCredentials
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   
 
-findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
 findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
   where
     userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
       , Ldap.size 2
-      , Ldap.time ldapTimeout
+      , Ldap.time ldapSearchTimeout
       , Ldap.derefAliases Ldap.DerefAlways
       ]
   
@@ -63,8 +54,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
-              , Button site SubmitButton
-              , Show (ButtonCssClass site)
+              , Button site ButtonSubmit
               ) => AForm (HandlerT site IO) CampusLogin
 campusForm = CampusLogin
   <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
@@ -75,10 +65,9 @@ campusLogin :: forall site.
                ( YesodAuth site
                , RenderMessage site FormMessage
                , RenderMessage site CampusMessage
-               , Button site SubmitButton
-               , Show (ButtonCssClass site)
-               ) => LdapConf -> AuthPlugin site
-campusLogin conf@LdapConf{..} = AuthPlugin{..}
+               , Button site ButtonSubmit
+               ) => LdapConf -> LdapPool -> AuthPlugin site
+campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
     apName = "LDAP"
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
@@ -90,13 +79,13 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
           redirect LoginR
         FormMissing -> redirect LoginR
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
-          ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
+          ldapResult <- withLdap pool $ \ldap -> do
             Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
             Ldap.bind ldap ldapDn ldapPassword
             findUser conf ldap campusIdent [userPrincipalName]
           case ldapResult of
             Left err
-              | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
+              | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
                 -> do
                   $logDebugS "LDAP" "Invalid credentials"
                   loginErrorMessageI LoginR Msg.InvalidLogin
@@ -118,18 +107,18 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
       $(widgetFile "widgets/campus-login-form")
 
-data CampusUserException = CampusUserLdapError Ldap.LdapError
+data CampusUserException = CampusUserLdapError LdapPoolError
                          | CampusUserHostNotResolved String
                          | CampusUserLineTooLong
                          | CampusUserHostCannotConnect String [IOException]
                          | CampusUserNoResult
                          | CampusUserAmbiguous
-  deriving (Show, Eq, Typeable)
+  deriving (Show, Eq, Generic, Typeable)
 
 instance Exception CampusUserException
 
-campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
-campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
+campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO 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
     Just userDN -> do
@@ -137,7 +126,7 @@ campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ eith
           userSearchSettings = mconcat
             [ Ldap.scope Ldap.BaseObject
             , Ldap.size 2
-            , Ldap.time ldapTimeout
+            , Ldap.time ldapSearchTimeout
             , Ldap.derefAliases Ldap.DerefAlways
             ]
       Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []

src/Auth/PWHash.hs

@@ -1,13 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , QuasiQuotes
-           , TemplateHaskell
-           , ViewPatterns
-           , RecordWildCards
-           , OverloadedStrings
-           , FlexibleContexts
-           , TypeFamilies
-  #-}
-
 module Auth.PWHash
   ( hashLogin
   , PWHashMessage(..)
@@ -29,16 +19,16 @@ import qualified Yesod.Auth.Message as Msg
 data HashLogin = HashLogin
   { hashIdent :: CI Text
   , hashPassword :: Text
-  }
+  } deriving (Generic, Typeable)
 
 data PWHashMessage = MsgPWHashIdent
                    | MsgPWHashPassword
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
 hashForm :: ( RenderMessage site FormMessage
             , RenderMessage site PWHashMessage
-            , Button site SubmitButton
-            , Show (ButtonCssClass site)
+            , Button site ButtonSubmit
             ) => AForm (HandlerT site IO) HashLogin
 hashForm = HashLogin
   <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
@@ -51,8 +41,7 @@ hashLogin :: ( YesodAuth site
              , SqlBackendCanRead (YesodPersistBackend site)
              , RenderMessage site FormMessage
              , RenderMessage site PWHashMessage
-             , Button site SubmitButton
-             , Show (ButtonCssClass site)
+             , Button site ButtonSubmit
              ) => PWHashAlgorithm -> AuthPlugin site
 hashLogin pwHashAlgo = AuthPlugin{..}
   where

src/Cron.hs

@@ -0,0 +1,254 @@
+module Cron
+  ( evalCronMatch
+  , CronNextMatch(..)
+  , nextCronMatch
+  , module Cron.Types
+  ) where
+
+import ClassyPrelude
+import Prelude (lcm)
+import Cron.Types
+
+import Data.Time
+import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid)
+import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid)
+import Data.Time.Zones
+
+import Numeric.Natural
+import Data.Ratio ((%))
+
+import qualified Data.Set as Set
+
+import Utils.Lens hiding (from, to)
+
+  
+data CronDate = CronDate
+  { cdYear, cdWeekOfYear, cdDayOfYear
+  , cdMonth, cdWeekOfMonth, cdDayOfMonth
+  , cdDayOfWeek
+  , cdHour, cdMinute, cdSecond :: Natural
+  } deriving (Eq, Show, Read)
+
+makeLenses_ ''CronDate
+
+
+evalCronMatch :: CronMatch -> Natural -> Bool
+evalCronMatch CronMatchAny _ = True
+evalCronMatch CronMatchNone _ = False
+evalCronMatch (CronMatchSome xs) x = Set.member x $ toNullable xs
+evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0
+evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
+evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
+evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x
+
+toCronDate :: LocalTime -> CronDate
+toCronDate LocalTime{..} = CronDate{..}
+  where
+    (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth)
+      = toGregorian localDay
+    (_, fromIntegral -> cdDayOfYear)
+      = toOrdinalDate localDay
+    (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
+      = toWeekDate localDay
+    cdWeekOfMonth = go 1 localDay
+      where
+        go :: Natural -> Day -> Natural
+        go n day
+          | dow /= 4  = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday
+          | m == m'   = go (succ n) day'
+          | otherwise = n
+          where
+            (y, w, dow) = toWeekDate day
+            day'
+              | w /= 0 = fromWeekDate y (pred w) dow
+              | otherwise = fromWeekDate (pred y) 53 dow
+            (_, m, _) = toGregorian day
+            (_, m', _) = toGregorian day'
+    TimeOfDay
+      { todHour = fromIntegral -> cdHour
+      , todMin = fromIntegral -> cdMinute
+      , todSec = round -> cdSecond
+      } = localTimeOfDay
+
+consistentCronDate :: CronDate -> Bool
+consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
+  gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
+  wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
+  guard $ gDay == wDay
+  oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
+  guard $ wDay == oDay
+  guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate"))
+  return True
+
+
+data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
+  deriving (Eq, Ord, Show, Read, Functor)
+
+instance Applicative CronNextMatch where
+  pure = MatchAt
+  _ <*> MatchNone = MatchNone
+  MatchNone <*> _ = MatchNone
+  _ <*> MatchAsap = MatchAsap
+  MatchAsap <*> _ = MatchAsap
+  MatchAt f <*> MatchAt x = MatchAt $ f x
+
+instance Alternative CronNextMatch where
+  empty = MatchNone
+  x <|> MatchNone = x
+  MatchNone <|> x = x
+  _ <|> MatchAsap = MatchAsap
+  MatchAsap <|> _ = MatchAsap
+  (MatchAt a) <|> (MatchAt _) = MatchAt a
+  
+
+listToMatch :: [a] -> CronNextMatch a
+listToMatch [] = MatchNone
+listToMatch (t:_) = MatchAt t
+
+genMatch :: Int -- ^ Period
+         -> Bool -- ^ Modular
+         -> Natural -- ^ Start value
+         -> CronMatch
+         -> [Natural]
+genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
+genMatch _ _ _ CronMatchNone = []
+genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs
+genMatch p m st (CronMatchStep step) = do
+  start <- [st..st + step]
+  guard $ (start `mod` step) == 0
+  take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
+genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
+genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
+genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
+genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
+genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
+genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
+  = genMatch p m st . CronMatchStep $ lcm st1 st2
+genMatch p m st (CronMatchIntersect aGen bGen)
+  | [] <- as' = []
+  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
+  where
+    as' = genMatch p m st aGen
+    mergeAnd [] _ = []
+    mergeAnd _ [] = []
+    mergeAnd (a:as) (b:bs)
+      | a <  b    = mergeAnd as (b:bs)
+      | a == b    = a : mergeAnd as bs
+      | otherwise = mergeAnd (a:as) bs
+genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
+genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
+genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
+genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
+genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
+  where
+    merge [] bs = bs
+    merge as [] = as
+    merge (a:as) (b:bs)
+      | a <  b    = a : merge as (b:bs)
+      | a == b    = a : merge as bs
+      | otherwise = b : merge (a:as) bs
+
+nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
+              -> Maybe UTCTime -- ^ Time of last execution of the job
+              -> NominalDiffTime -- ^ Scheduling precision
+              -> UTCTime -- ^ Current time, used only for `CronCalendar`
+              -> Cron
+              -> CronNextMatch UTCTime
+nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
+  MatchAsap -> MatchNone
+  MatchAt ts
+    | MatchAt ts' <- nextMatch
+    , ts' <= ts -> MatchAt ts'
+    | MatchAsap <- nextMatch
+    , now <= ts -> MatchAsap
+    | otherwise -> MatchNone
+  MatchNone -> nextMatch
+  where
+    notAfter
+      | Right c' <- cronNotAfter
+      , Just ref <- notAfterRef
+      = execRef' ref False c'
+      | Left diff <- cronNotAfter
+      , Just ref <- notAfterRef
+      = MatchAt $ diff `addUTCTime` ref
+      | otherwise = MatchNone
+    notAfterRef
+      | Just prevT <- mPrev = Just prevT
+      | otherwise = case execRef' now False cronInitial of
+          MatchAsap -> error "execRef' should not return MatchAsap"
+          MatchAt t -> Just t
+          MatchNone -> Nothing
+    nextMatch = case mPrev of
+      Nothing
+        -> execRef now False cronInitial
+      Just prevT
+        -> case cronRepeat of
+            CronRepeatOnChange
+              | not $ matchesCron tz Nothing prec prevT c
+                -> let
+                     cutoffTime = addUTCTime cronRateLimit prevT
+                   in case execRef now False cronInitial of
+                        MatchAsap
+                          | now < cutoffTime -> MatchAt cutoffTime
+                        MatchAt ts 
+                          | ts < cutoffTime -> MatchAt cutoffTime
+                        other -> other
+            CronRepeatScheduled cronNext
+              -> case cronNext of
+                   CronAsap
+                     | addUTCTime cronRateLimit prevT <= now
+                       -> MatchAsap
+                     | otherwise
+                       -> MatchAt $ addUTCTime cronRateLimit prevT
+                   _other
+                     -> execRef (addUTCTime cronRateLimit prevT) True cronNext
+            _other -> MatchNone
+
+    execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
+      MatchAt t
+        | t <= ref -> MatchAsap
+      other -> other
+
+    execRef' ref wasExecd cronAbsolute = case cronAbsolute of
+      CronAsap -> MatchAt ref
+      CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
+        | ref <= ts || not wasExecd -> MatchAt ts
+        | otherwise -> MatchNone
+      CronCalendar{..} -> listToMatch $ do
+        let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
+
+        mCronYear <- genMatch 400 False cdYear cronYear
+        mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
+        mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
+        mCronMonth <- genMatch 12 True cdMonth cronMonth
+        mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
+        mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
+        mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
+        mCronHour <- genMatch 24 True cdHour cronHour
+        mCronMinute <- genMatch 60 True cdMinute cronMinute
+        mCronSecond <- genMatch 60 True cdSecond cronSecond
+        guard $ consistentCronDate CronDate
+          { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
+          , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
+          , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
+          , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
+          }
+
+        localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
+        let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
+        return $ localTimeToUTCTZ tz LocalTime{..}
+      CronNotScheduled -> MatchNone
+
+matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
+            -> Maybe UTCTime -- ^ Previous execution of the job
+            -> NominalDiffTime -- ^ Scheduling precision
+            -> UTCTime -- ^ "Current" time
+            -> Cron
+            -> Bool
+-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
+--   specification @c@ should match @now@, under the assumption that the next
+--   check will occur no earlier than @now + prec@.
+matchesCron tz mPrev prec now cron = case nextCronMatch tz mPrev prec now cron of
+  MatchAsap -> True
+  MatchNone -> False
+  MatchAt ts -> ts <= addUTCTime prec now

src/Cron/Types.hs

@@ -0,0 +1,61 @@
+module Cron.Types
+  ( Cron(..), Crontab
+  , CronMatch(..)
+  , CronAbsolute(..)
+  , CronRepeat(..)
+  ) where
+
+import ClassyPrelude
+
+import Utils.Lens.TH
+
+import Data.Time 
+
+import Numeric.Natural
+
+import Data.HashMap.Strict (HashMap)
+  
+
+data CronMatch
+  = CronMatchAny
+  | CronMatchNone
+  | CronMatchSome (NonNull (Set Natural))
+  | CronMatchStep Natural
+  | CronMatchContiguous Natural Natural
+  | CronMatchIntersect CronMatch CronMatch
+  | CronMatchUnion CronMatch CronMatch
+  deriving (Eq, Show, Read)
+
+data CronAbsolute
+  = CronAsap
+  | CronTimestamp
+    { cronTimestamp :: LocalTime
+    }
+  | CronCalendar
+    { cronYear, cronWeekOfYear, cronDayOfYear
+    , cronMonth, cronWeekOfMonth, cronDayOfMonth
+    , cronDayOfWeek
+    , cronHour, cronMinute, cronSecond :: CronMatch
+    }
+  | CronNotScheduled
+  deriving (Eq, Show, Read)
+
+makeLenses_ ''CronAbsolute
+
+data CronRepeat
+  = CronRepeatOnChange
+  | CronRepeatScheduled CronAbsolute
+  | CronRepeatNever
+  deriving (Eq, Show, Read)
+
+data Cron = Cron
+  { cronInitial :: CronAbsolute
+  , cronRepeat :: CronRepeat
+  , cronRateLimit :: NominalDiffTime
+  , cronNotAfter :: Either NominalDiffTime CronAbsolute
+  }
+  deriving (Eq, Show)
+
+makeLenses_ ''Cron
+
+type Crontab a = HashMap a Cron

src/CryptoID.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module CryptoID
@@ -17,7 +9,7 @@ module CryptoID
 
 import CryptoID.TH
 
-import ClassyPrelude hiding (fromString)
+import ClassyPrelude
 import Model
 
 import qualified Data.CryptoID as E
@@ -33,11 +25,17 @@ import Web.PathPieces
 import           Data.CaseInsensitive   (CI)
 import qualified Data.CaseInsensitive as CI
 
+import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
+import Data.Aeson.Encoding (text)
+
 
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId
              , ''UserId
+             , ''SheetId
+             , ''SystemMessageId
+             , ''SystemMessageTranslationId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
@@ -46,6 +44,15 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
     return . CryptoID . CI.mk $ map CI.original piece'
   toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
 
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where
+  toJSON = String . toPathPiece
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where
+  toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where
+  parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
+  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
+
 
 newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
   deriving (Show, Read, Eq)

src/CryptoID/TH.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-
 module CryptoID.TH where
 
 import ClassyPrelude
@@ -10,14 +6,11 @@ import Language.Haskell.TH
 
 import Data.CryptoID.Class.ImplicitNamespace
 import Data.UUID.Types (UUID)
-import Data.Binary (Binary(..))
 import Data.Binary.SerializationLength
 
 import Data.CaseInsensitive (CI)
 import System.FilePath (FilePath)
 
-import Database.Persist.Sql (toSqlKey, fromSqlKey)
-
 
 decCryptoIDs :: [Name] -> DecsQ
 decCryptoIDs = fmap concat . mapM decCryptoID
@@ -25,9 +18,6 @@ decCryptoIDs = fmap concat . mapM decCryptoID
     decCryptoID :: Name -> DecsQ
     decCryptoID n@(conT -> t) = do
       instances <- [d|
-          instance Binary $(t) where
-            get = $(varE 'toSqlKey) <$> get
-            put = put . $(varE 'fromSqlKey)
           instance HasFixedSerializationLength $(t) where
             type SerializationLength $(t) = SerializationLength Int64
 

src/Data/CaseInsensitive/Instances.hs

@@ -1,13 +1,11 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.CaseInsensitive.Instances
-  () where
+  (
+  ) where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (lift)
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -15,10 +13,19 @@ import qualified Data.CaseInsensitive as CI
 import Database.Persist.Sql
 
 import Text.Blaze (ToMarkup(..))
+import Text.Shakespeare.Text (ToText(..))
 
 import Data.Text (Text)
 import qualified Data.Text.Encoding as Text
 
+import Language.Haskell.TH.Syntax (Lift(..))
+
+import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
+
+import qualified Database.Esqueleto as E
+
+import Web.HttpApiData
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -36,12 +43,22 @@ instance PersistFieldSql (CI Text) where
 instance PersistFieldSql (CI String) where
   sqlType _ = SqlOther "citext"
 
+instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
+
 instance ToJSON a => ToJSON (CI a) where
   toJSON = toJSON . CI.original
 
 instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
   parseJSON = fmap CI.mk . parseJSON
 
+instance (ToJSONKey a, ToJSON a) => ToJSONKey (CI a) where
+  toJSONKey = case toJSONKey of
+    ToJSONKeyText  toVal toEnc -> ToJSONKeyText (toVal . CI.original) (toEnc . CI.original)
+    ToJSONKeyValue toVal toEnc -> ToJSONKeyValue (toVal . CI.original) (toEnc . CI.original)
+
+instance (FromJSON a, FromJSONKey a, CI.FoldCase a) => FromJSONKey (CI a) where
+  fromJSONKey = CI.mk <$> fromJSONKey
+
 instance ToMessage a => ToMessage (CI a) where
   toMessage = toMessage . CI.original
 
@@ -49,8 +66,31 @@ instance ToMarkup a => ToMarkup (CI a) where
   toMarkup = toMarkup . CI.original
   preEscapedToMarkup = preEscapedToMarkup . CI.original
 
+instance ToText a => ToText (CI a) where
+  toText = toText . CI.original
+
 instance ToWidget site a => ToWidget site (CI a) where
   toWidget = toWidget . CI.original
 
 instance RenderMessage site a => RenderMessage site (CI a) where
   renderMessage f ls msg = renderMessage f ls $ CI.original msg
+
+instance Lift t => Lift (CI t) where
+  lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
+
+
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+  fromPathPiece = fmap CI.mk . fromPathPiece
+  toPathPiece = toPathPiece . CI.original
+
+instance ToHttpApiData (CI Text) where
+  toUrlPiece = toUrlPiece . CI.original
+  toEncodedUrlPiece = toEncodedUrlPiece . CI.original
+
+instance FromHttpApiData (CI Text) where
+  parseUrlPiece = fmap CI.mk . parseUrlPiece
+
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+  fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+

src/Data/Monoid/Instances.hs

@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Monoid.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Monoid
+
+type instance Element (Dual a) = a
+instance MonoPointed (Dual a)
+type instance Element (Sum a) = a
+instance MonoPointed (Sum a)
+type instance Element (Product a) = a
+instance MonoPointed (Product a)
+type instance Element (First a) = a
+instance MonoPointed (First a)
+type instance Element (Last a) = a
+instance MonoPointed (Last a)

src/Data/Universe/Instances/Reverse/Hashable.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.Hashable
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Universe
+
+
+instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where
+  hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ]

src/Data/Universe/Instances/Reverse/JSON.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.JSON
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict ((!))
+
+import Data.Universe
+
+
+instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where
+  toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF]
+
+instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
+  parseJSON val = do
+    vMap <- parseJSON val :: Parser (HashMap a b)
+    unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
+      fail "Not all required keys found"
+    return (vMap !)

src/Database/Esqueleto/Instances.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Esqueleto.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import qualified Database.Esqueleto as E
+
+import Data.Binary (Binary)
+import qualified Data.Binary as B
+
+
+instance ToJSON a => ToJSON (E.Value a) where
+  toJSON = toJSON . E.unValue
+
+instance FromJSON a => FromJSON (E.Value a) where
+  parseJSON = fmap E.Value . parseJSON
+
+
+instance Binary a => Binary (E.Value a) where
+  put = B.put . E.unValue
+  get = E.Value <$> B.get
+  putList = B.putList . map E.unValue

src/Database/Persist/Sql/Instances.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Sql.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Data.Binary (Binary)
+import qualified Data.Binary as B
+
+import Database.Persist.Sql
+
+
+instance Binary (BackendKey SqlWriteBackend) where
+  put = B.put . unSqlWriteBackendKey
+  putList = B.putList . map unSqlWriteBackendKey
+  get = SqlWriteBackendKey <$> B.get
+instance Binary (BackendKey SqlReadBackend) where
+  put = B.put . unSqlReadBackendKey
+  putList = B.putList . map unSqlReadBackendKey
+  get = SqlReadBackendKey <$> B.get
+instance Binary (BackendKey SqlBackend) where
+  put = B.put . unSqlBackendKey
+  putList = B.putList . map unSqlBackendKey
+  get = SqlBackendKey <$> B.get
+  
+
+instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where
+  put = B.put . fromSqlKey
+  putList = B.putList . map fromSqlKey
+  get = toSqlKey <$> B.get

src/Database/Persist/TH/Directory.hs

@@ -0,0 +1,27 @@
+module Database.Persist.TH.Directory
+  ( persistDirectoryWith
+  ) where
+
+import ClassyPrelude hiding (mapM_, toList)
+
+import Database.Persist.TH (parseReferences)
+import Database.Persist.Quasi (PersistSettings)
+import Language.Haskell.TH.Syntax
+
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified System.IO as SIO
+
+import qualified System.Directory.Tree as DirTree
+
+import Data.Foldable (Foldable(..), mapM_)
+
+persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
+persistDirectoryWith settings dir = do
+  files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do
+    h <- SIO.openFile fp SIO.ReadMode
+    SIO.hSetEncoding h SIO.utf8_bom
+    Text.hGetContents h
+  mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files
+  
+  parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files

src/Handler/Admin.hs

@@ -1,24 +1,19 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.Admin where
 
 import Import
 import Handler.Utils
+import Jobs
+
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+
+import Control.Monad.Trans.Except
 
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
+import Database.Persist.Sql (fromSqlKey)
 
 -- import Colonnade hiding (fromMaybe)
 -- import Yesod.Colonnade
@@ -26,46 +21,96 @@ import Web.PathPieces (showToPathPiece, readFromPathPiece)
 -- import qualified Data.UUID.Cryptographic as UUID
 
 -- BEGIN - Buttons needed only here
-data CreateButton = CreateMath | CreateInf  -- Dummy for Example
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCreate
+instance Finite ButtonCreate
 
-instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+nullaryPathPiece ''ButtonCreate camelToPathPiece
 
-instance Button UniWorX CreateButton where
-  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"
+instance Button UniWorX ButtonCreate where
+  btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
+  btnLabel CreateInf  = "Informatik"
 
-  cssClass CreateMath = BCInfo
-  cssClass CreateInf  = BCPrimary
+  btnClasses CreateMath = [BCIsButton, BCInfo]
+  btnClasses CreateInf  = [BCIsButton, BCPrimary]
 -- END Button needed here
 
+emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
+emailTestForm = (,)
+            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
+            <*> ( MailContext
+                  <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
+                  <*> (toMailDateTimeFormat
+                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
+                      )
+                )
+            <*  submitButton
+  where
+    toMailDateTimeFormat dt d t = \case
+      SelFormatDateTime -> dt
+      SelFormatDate -> d
+      SelFormatTime -> t
 
-getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
-getAdminTestR = do
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
-  defaultLayout $ do
-    -- setTitle "Uni2work Admin Testpage"
-    $(widgetFile "adminTest")
 
-postAdminTestR :: Handler Html
+getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = postAdminTestR
 postAdminTestR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
   case btnResult of
     (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
     (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+    FormMissing -> return ()
     _other -> addMessage Warning "KEIN Knopf erkannt"
-  getAdminTestR
+
+  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
+  case emailResult of 
+    (FormSuccess (email, ls)) -> do
+      jId <- runDB $ do
+        jId <- queueJob $ JobSendTestEmail email ls
+        addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+        return jId
+      writeJobCtl $ JobCtlPerform jId
+    FormMissing -> return ()
+    (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
+
+  let emailWidget' = [whamlet|
+        <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
+          ^{emailWidget}
+      |]
+  
+  defaultLayout $
+    -- setTitle "Uni2work Admin Testpage"
+    $(widgetFile "adminTest")
 
 
 getAdminUserR :: CryptoUUIDUser -> Handler Html
 getAdminUserR uuid = do
   uid <- decrypt uuid
   User{..} <- runDB $ get404 uid
-  defaultLayout $
+  defaultLayout
     [whamlet|
       <h1>TODO
       <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
     |]
 
+getAdminErrMsgR, postAdminErrMsgR :: Handler Html
+getAdminErrMsgR = postAdminErrMsgR
+postAdminErrMsgR = do
+  ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
+        (unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
+    <*  submitButton
+
+  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
+
+  defaultLayout
+    [whamlet|
+      $maybe t <- plaintext
+        <pre style="white-space:pre-wrap; font-family:monospace">
+          #{encodePrettyToTextBuilder t}
+
+      <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
+        ^{ctView}
+    |]

src/Handler/Common.hs

@@ -1,13 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
 -- | Common handler functions.
 module Handler.Common where
 
 import Data.FileEmbed (embedFile)
-import Import
+import Import hiding (embedFile)
 
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
@@ -15,8 +10,8 @@ import Import
 getFaviconR :: Handler TypedContent
 getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                  return $ TypedContent "image/x-icon"
-                        $ toContent $(embedFile "embedded/favicon.ico")
+                        $ toContent $(embedFile "static/favicon.ico")
 
 getRobotsR :: Handler TypedContent
 getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "embedded/robots.txt")
+                    $ toContent $(embedFile "static/robots.txt")

src/Handler/Course.hs

@@ -1,54 +1,34 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.Course where
 
-import Import hiding (catMaybes)
+import Import
 
-import Control.Lens
 import Utils.Lens
-import Utils.TH
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
+import Handler.Utils.Course
+import Handler.Utils.Delete
 
 -- import Data.Time
 import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
-import Data.Maybe
+import Data.Monoid (Last(..))
+
+import Data.Maybe (fromJust)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import qualified Data.CaseInsensitive as CI
-
-
-import Colonnade hiding (fromMaybe,bool)
--- import Yesod.Colonnade
-
 import qualified Database.Esqueleto as E
 
-import qualified Data.UUID.Cryptographic as UUID
 
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
 
 colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
               [whamlet|#{display courseName}|]
 
@@ -59,19 +39,19 @@ colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
 
 colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colDescription = sortable Nothing (i18nCell MsgCourseDescription)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             case courseDescription of
               Nothing      -> mempty
               (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
 
 colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
 
 colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
             ( case courseDescription of
                 Nothing      -> mempty
@@ -85,7 +65,7 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
 
 colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
 
 colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@@ -100,24 +80,24 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
 
 colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             maybe mempty timeCell courseRegisterFrom
             -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
 
 colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
-            cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
+            maybe mempty timeCell courseRegisterTo
 
 colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
               Nothing -> MsgCourseMembersCount currentParticipants
-              Just max -> MsgCourseMembersCountLimited currentParticipants max
+              Just limit -> MsgCourseMembersCountLimited currentParticipants limit
 
 colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered
+          $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered
 
 type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
 
@@ -127,14 +107,14 @@ course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \co
     return (E.countRows :: E.SqlExpr (E.Value Int64))
 
 course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
-course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do
+course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
     E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
       E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
 
-makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
 makeCourseTable whereClause colChoices psValidator = do
-  muid <- maybeAuthId
+  muid <- lift maybeAuthId
   let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
       dbtSQLQuery qin@(course `E.InnerJoin` school) = do
         E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
@@ -144,8 +124,9 @@ makeCourseTable whereClause colChoices psValidator = do
         return (course, participants, registered, school)
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
       dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
-  dbTable psValidator $ DBTable
+  snd <$> dbTable psValidator DBTable
     { dbtSQLQuery
+    , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
     , dbtColonnade = colChoices
     , dbtProj
     , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
@@ -156,7 +137,7 @@ makeCourseTable whereClause colChoices psValidator = do
         , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
         , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
         , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
-        , ( "participants",  SortColumn $ course2Participants   )
+        , ( "participants",  SortColumn   course2Participants   )
         , ( "registered",    SortColumn $ course2Registered muid)
         ]
     , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
@@ -183,28 +164,43 @@ makeCourseTable whereClause colChoices psValidator = do
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
           )
+        , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> course2Registered muid tExpr E.==. E.val needle
+          )
+        , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+          )
         ]
-    , dbtStyle = def
+    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
+      [ Just  $ prismAForm (singletonFilter "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch)
+      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
+      ]
+    , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+    , dbtParams = def
     , dbtIdent = "courses" :: Text
     }
 
 getCourseListR :: Handler Html
-getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
+getCourseListR = do
   muid <- maybeAuthId
   let colonnade = widgetColonnade $ mconcat
         [ colCourseDescr
-        , colCShort
+        , colSchoolShort
         , colTerm
+        , colCShort
         , maybe mempty (const colRegistered) muid
-        , colSchool
+
         ]
       whereClause = const $ E.val True
       validator = def
-        & defaultSorting [("course", SortAsc), ("term", SortDesc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+        & defaultSorting [SortAscBy "course", SortDescBy "term"]
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI MsgCourseListTitle
-    [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
     $(widgetFile "courses")
 
 getTermCurrentR :: Handler Html
@@ -228,12 +224,12 @@ getTermSchoolCourseListR tid ssh = do
         , colParticipants
         , maybe mempty (const colRegistered) muid
         ]
-      whereClause = \(course, _, _) ->
-                course E.^. CourseTerm   E.==. E.val tid
-          E.&&. course E.^. CourseSchool E.==. E.val ssh
+      whereClause (course, _, _) =
+              course E.^. CourseTerm   E.==. E.val tid
+        E.&&. course E.^. CourseSchool E.==. E.val ssh
       validator = def
-        & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+        & defaultSorting [SortAscBy "cshort"]
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI $ MsgTermSchoolCourseListTitle tid school
     $(widgetFile "courses")
@@ -252,10 +248,10 @@ getTermCourseListR tid = do
         , colParticipants
         , maybe mempty (const colRegistered) muid
         ]
-      whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
+      whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
       validator = def
-        & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+        & defaultSorting [SortAscBy "cshort"]
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI . MsgTermCourseListTitle $ tid
     $(widgetFile "courses")
@@ -263,34 +259,40 @@ getTermCourseListR tid = do
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
-      courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-      dependent <- (,,)
-          <$> get (courseSchool course)               -- join -- just fetch full school name here
-          <*> count [CourseParticipantCourse ==. cid] -- join
-          <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
-                Nothing -> return False
-                (Just aid) -> do  regL <- getBy (UniqueParticipant aid cid)
-                                  return $ isJust regL)
-      lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
-          E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
-          E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
-          return $ user E.^. UserDisplayName
-      return $ (courseEnt,dependent,E.unValue <$> lecturers)
-  let course = entityVal courseEnt
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do
+    [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
+       <- lift . E.select . E.from $
+         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
+            E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
+                E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
+            E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                 E.&&. course E.^. CourseShorthand E.==. E.val csh
+            let numParticipants = E.sub_select . E.from $ \part -> do
+                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                  return ( E.countRows :: E.SqlExpr (E.Value Int64))
+            return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration)
+    lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
+      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+      E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+      return $ user E.^. UserDisplayName
+    return (course,schoolName,participants,registered,map E.unValue lecturers)
+  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
+  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
+  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
+  mRegAt   <- traverse (formatTime SelFormatDateTime)   registered
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
-  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
-  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
   defaultLayout $ do
-    setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
+    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
 
 registerForm :: Bool -> Maybe Text -> Form Bool
 registerForm registered msecret extra = do
   (msecretRes', msecretView) <- case msecret of
-    (Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
+    (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
     _ -> return (Nothing,Nothing)
   (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
   let widget = $(widgetFile "widgets/registerForm")
@@ -304,7 +306,7 @@ postCRegisterR tid ssh csh = do
   aid <- requireAuthId
   (cid, course, registered) <- runDB $ do
       (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-      registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
+      registered <- isJust <$> getBy (UniqueParticipant aid cid)
       return (cid, course, registered)
   ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
   case regResult of
@@ -313,21 +315,14 @@ postCRegisterR tid ssh csh = do
           runDB $ deleteBy $ UniqueParticipant aid cid
           addMessageI Info MsgCourseDeregisterOk
       | codeOk -> do
-          actTime <- liftIO $ getCurrentTime
+          actTime <- liftIO getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
           when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
       | otherwise -> addMessageI Warning MsgCourseSecretWrong
-    (_other) -> return () -- TODO check this!
+    _other -> return () -- TODO check this!
   redirect $ CourseR tid ssh csh CShowR
 
 
-getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
-getCourseNewTemplateR mbTid mbSsh mbCsh =
-  redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey    <$> mbTid
-                                  , ("ssh",).CI.original.unSchoolKey <$> mbSsh
-                                  , ("csh",).CI.original             <$> mbCsh
-                                  ])
-
 getCourseNewR :: Handler Html -- call via toTextUrl
 getCourseNewR = do
   uid <- requireAuthId
@@ -338,21 +333,20 @@ getCourseNewR = do
   let noTemplateAction = courseEditHandler True Nothing
   case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
     FormMissing      -> noTemplateAction
-    FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
+    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
                         noTemplateAction
     FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
-      uid <- requireAuthId
-      oldCourses <- runDB $ do
+      oldCourses <- runDB $
         E.select $ E.from $ \course -> do
           whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
           whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
           whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
           let lecturersCourse =
-                E.exists $ E.from $ \lecturer -> do
+                E.exists $ E.from $ \lecturer ->
                   E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
                       E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
           let lecturersSchool =
-                E.exists $ E.from $ \user -> do
+                E.exists $ E.from $ \user ->
                   E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
                       E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
           let courseCreated c =
@@ -366,7 +360,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = (courseToForm oldTemplate) in
+            let newTemplate = courseToForm oldTemplate in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -378,7 +372,7 @@ getCourseNewR = do
             (tidOk,sshOk,cshOk) <- runDB $ (,,)
                 <$> ifMaybeM mbTid True existsKey
                 <*> ifMaybeM mbSsh True existsKey
-                <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
             unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
             unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
             unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@@ -401,36 +395,32 @@ pgCEditR isGetReq tid ssh csh = do
   courseEditHandler isGetReq $ courseToForm <$> course
 
 
-getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCDeleteR = error "TODO: implement getCDeleteR"
-postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-postCDeleteR = error "TODO: implement getCDeleteR"
-{- TODO
-        | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
-        , Just cid <- cfCourseId res -> do
-            runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
-            let cti = toPathPiece $ cfTerm res
-            addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
-            redirect $ TermCourseListR $ cfTerm res
--}
+getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCDeleteR = postCDeleteR
+postCDeleteR tid ssh csh = do
+  Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  deleteR $ (courseDeleteRoute $ Set.singleton cId)
+    { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
+    , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
+    }
 
 
 -- | Course Creation and Editing
 -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
 -- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
-courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html
-courseEditHandler isGet mbCourseForm = do
+courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used
+courseEditHandler _isGet mbCourseForm = do
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
     ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
     case result of
-      (FormSuccess res@(
-        CourseForm  { cfCourseId = Nothing
-                    , cfShort    = csh
-                    , cfSchool   = ssh
-                    , cfTerm     = tid
-                    })) ->  do -- create new course
+      (FormSuccess res@CourseForm
+        { cfCourseId = Nothing
+        , cfShort    = csh
+        , cfSchool   = ssh
+        , cfTerm     = tid
+        }) -> do -- create new course
           now <- liftIO getCurrentTime
-          insertOkay <- runDB $ insertUnique $ Course
+          insertOkay <- runDB $ insertUnique Course
             { courseName            = cfName     res
             , courseDescription     = cfDesc     res
             , courseLinkExternal    = cfLink     res
@@ -454,34 +444,33 @@ courseEditHandler isGet mbCourseForm = do
             Nothing ->
               addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
 
-      (FormSuccess res@(
-        CourseForm  { cfCourseId = Just cid
-                    , cfShort    = csh
-                    , cfSchool   = ssh
-                    , cfTerm     = tid
-                    })) -> do -- edit existing course
+      (FormSuccess res@CourseForm
+        { cfCourseId = Just cid
+        , cfShort    = csh
+        , cfSchool   = ssh
+        , cfTerm     = tid
+        }) -> do -- edit existing course
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
           success <- runDB $ do
             old <- get cid
             case old of
               Nothing -> addMessageI Error MsgInvalidInput $> False
-              (Just oldCourse) -> do
-                updOkay <- myReplaceUnique cid (  -- replaceUnique requires Eq Course, which we cannot have
-                    Course  {  courseName            = cfName       res
-                            ,  courseDescription     = cfDesc       res
-                            ,  courseLinkExternal    = cfLink       res
-                            ,  courseShorthand       = cfShort      res
-                            ,  courseTerm            = cfTerm       res -- dangerous
-                            ,  courseSchool          = cfSchool     res
-                            ,  courseCapacity        = cfCapacity   res
-                            ,  courseRegisterSecret  = cfSecret     res
-                            ,  courseMaterialFree    = cfMatFree    res
-                            ,  courseRegisterFrom    = cfRegFrom    res
-                            ,  courseRegisterTo      = cfRegTo      res
-                            ,  courseDeregisterUntil = cfDeRegUntil res
-                    }
-                  )
+              (Just _) -> do
+                updOkay <- myReplaceUnique cid Course
+                  { courseName            = cfName       res
+                  , courseDescription     = cfDesc       res
+                  , courseLinkExternal    = cfLink       res
+                  , courseShorthand       = cfShort      res
+                  , courseTerm            = cfTerm       res -- dangerous
+                  , courseSchool          = cfSchool     res
+                  , courseCapacity        = cfCapacity   res
+                  , courseRegisterSecret  = cfSecret     res
+                  , courseMaterialFree    = cfMatFree    res
+                  , courseRegisterFrom    = cfRegFrom    res
+                  , courseRegisterTo      = cfRegTo      res
+                  , courseDeregisterUntil = cfDeRegUntil res
+                  }
                 case updOkay of
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
@@ -491,7 +480,7 @@ courseEditHandler isGet mbCourseForm = do
           when success $ redirect $ CourseR tid ssh csh CShowR
 
       (FormFailure _) -> addMessageI Warning MsgInvalidInput
-      (FormMissing) -> return ()
+      FormMissing -> return ()
     actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
     defaultLayout $ do
       setTitleI MsgCourseEditTitle
@@ -593,7 +582,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
 
 
 validateCourse :: CourseForm -> [Text]
-validateCourse (CourseForm{..}) =
+validateCourse CourseForm{..} =
   [ msg | (False, msg) <-
     [
       ( NTop cfRegFrom <= NTop cfRegTo
@@ -613,18 +602,32 @@ validateCourse (CourseForm{..}) =
 
 
 getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCUsersR tid ssh csh = undefined -- TODO
+getCUsersR = error "CUsersR: Not implemented"
 
 
 getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
-getCUserR tid ssh csh uuid = do
-  uid <- decrypt uuid
+getCUserR _tid _ssh _csh uCId = do
+  -- Has authorization checks (OR):
+  --
+  --   - User is current member of course
+  --   - User has submitted in course
+  --   - User is member of registered group for course
+  --   - User is member of a tutorial for course
+  --   - User is corrector for course
+  --   - User is a tutor for course
+  --   - User is a lecturer for course
+  uid <- decrypt uCId
   User{..} <- runDB $ get404 uid
-  defaultLayout $
+  -- USE src/utils/Form.formResult
+  defaultLayout -- TODO
     [whamlet|
-      <h1>TODO
-      <h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
+      <p>^{nameWidget userDisplayName userSurname}
     |]
 
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCHiWisR tid ssh csh = undefined -- TODO
+getCHiWisR = error "CHiWisR: Not implemented"
+
+getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
+getCNotesR = error "CNotesR: Not implemented"
+postCNotesR = error "CNotesR: Not implemented"

src/Handler/CryptoIDDispatch.hs

@@ -1,23 +1,9 @@
-{-# LANGUAGE NoImplicitPrelude
-           , DataKinds
-           , KindSignatures
-           , TypeFamilies
-           , FlexibleInstances
-           , TypeOperators
-           , RankNTypes
-           , PolyKinds
-           , RecordWildCards
-           , MultiParamTypeClasses
-           , ScopedTypeVariables
-           , ViewPatterns
-  #-}
-
 module Handler.CryptoIDDispatch
   ( getCryptoUUIDDispatchR
   , getCryptoFileNameDispatchR
   ) where
 
-import Import hiding (Proxy)
+import Import
 
 import Data.Proxy
 

src/Handler/Home.hs

@@ -1,48 +1,15 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-
 module Handler.Home where
 
 import Import
 import Handler.Utils
 
 import qualified Data.Map as Map
-
-import Data.Time hiding (formatTime)
--- import qualified Data.Text as T
--- import Yesod.Form.Bootstrap3
-
--- import Web.PathPieces (showToPathPiece, readFromPathPiece)
-
--- import Control.Lens
--- import Colonnade hiding (fromMaybe, singleton)
--- import Yesod.Colonnade
+import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 
--- import Text.Shakespeare.Text
-
+import Jobs
 import Development.GitRev
 
--- import qualified Data.UUID.Cryptographic as UUID
-
-
--- CONSTANTS: TODO: make configurable elsewhere
-offSheetDeadlines :: NominalDiffTime
-offSheetDeadlines   = 15
-offCourseDeadlines :: NominalDiffTime
-offCourseDeadlines  = 15
---offExamDeadlines :: NominalDiffTime
---offExamDeadlines    = 15
-
-
 
 getHomeR :: Handler Html
 getHomeR = do
@@ -58,43 +25,45 @@ homeAnonymous = do
   let tableData :: E.SqlExpr (Entity Course)
                   -> E.SqlQuery (E.SqlExpr (Entity Course))
       tableData course = do
-            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) --   DO: do this with isAuthorized in dbtProj
+            E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) --   DO: do this with isAuthorized in dbtProj
                 E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
-                E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
-                        E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+                E.&&. (       E.isNothing (course E.^. CourseRegisterTo)
+                        E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
+                      )
             return course
 
       colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
-          sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
+          sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             textCell $ display $ courseTerm course
-        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
+        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             textCell $ display $ courseSchool course
-        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
+        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
             let tid = courseTerm      course
                 ssh = courseSchool    course
                 csh = courseShorthand course
             anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
-        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
+        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
-  ((), courseTable) <- dbTable def $ DBTable
+  courseTable <- runDB $ dbTableWidget' def DBTable
     { dbtSQLQuery  = tableData
+    , dbtRowKey    = (E.^. CourseId)
     , dbtColonnade = colonnade
     , dbtProj      = return
     , dbtSorting   = Map.fromList
                       [ ( "term"
-                        , SortColumn $ \(course) -> course E.^. CourseTerm
+                        , SortColumn $ \course -> course E.^. CourseTerm
                         )
                       , ( "school"
-                        , SortColumn $ \(course) -> course E.^. CourseSchool
+                        , SortColumn $ \course -> course E.^. CourseSchool
                         )
                       , ( "course"
-                        , SortColumn $ \(course) -> course E.^. CourseShorthand
+                        , SortColumn $ \course -> course E.^. CourseShorthand
                         )
                       , ( "deadline"
-                        , SortColumn $ \(course) -> course E.^. CourseRegisterTo
+                        , SortColumn $ \course -> course E.^. CourseRegisterTo
                         )
                       ]
     , dbtFilter    =  mempty {- [ ( "term"
@@ -103,24 +72,24 @@ homeAnonymous = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
+    , dbtParams    = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  let features = $(widgetFile "featureList")
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
-  defaultLayout $ do
-    $(widgetFile "dsgvDisclaimer")
+  -- let features = $(widgetFile "featureList")
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
+  defaultLayout
+    -- (widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
 
 homeUser :: Key User -> Handler Html
 homeUser uid = do
   cTime <- liftIO getCurrentTime
-  let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
-
-      tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
-                   --                         (E.SqlExpr (Entity Course           )))
-                   --                         (E.SqlExpr (Entity Sheet            ))
-                _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
+  let tableData :: E.LeftOuterJoin
+                        (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
+                        (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
+                  -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
                                 , E.SqlExpr (E.Value SchoolId)
                                 , E.SqlExpr (E.Value CourseShorthand)
                                 , E.SqlExpr (E.Value SheetName)
@@ -128,14 +97,12 @@ homeUser uid = do
                                 , E.SqlExpr (E.Value (Maybe SubmissionId)))
       tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
         E.on $ submission E.?. SubmissionId    E.==. subuser      E.?. SubmissionUserSubmission
-            E.&&.       (E.just $ E.val uid)   E.==. subuser      E.?. SubmissionUserUser
+         E.&&. E.just (E.val uid)              E.==. subuser      E.?. SubmissionUserUser
         E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
         E.on $ course     E.^. CourseId        E.==. sheet        E.^. SheetCourse
         E.on $ course     E.^. CourseId        E.==. participant  E.^. CourseParticipantCourse
         E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
             E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
-            E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime
-        -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
         return
           ( course  E.^. CourseTerm
           , course  E.^. CourseSchool
@@ -166,15 +133,16 @@ homeUser uid = do
             anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
         , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
             cell $ formatTime SelFormatDateTime deadline >>= toWidget
-        , sortable (Just "done")   (i18nCell MsgDone)   $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
+        , sortable (Just "done")   (i18nCell MsgDone)   $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
             case mbsid of
               Nothing    -> mempty
               (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
                                         tickmark
         ]
-  let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
-  ((), sheetTable) <- dbTable validator $ DBTable
+  let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
+  sheetTable <- runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
+    , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
     , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
                         -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
@@ -204,14 +172,16 @@ homeUser uid = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
+    , dbtFilterUI  = mempty
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
+    , dbtParams    = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
-  defaultLayout $ do
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  defaultLayout $
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")
-    $(widgetFile "dsgvDisclaimer")
+    -- (widgetFile "dsgvDisclaimer")
 
 
 getVersionR :: Handler TypedContent
@@ -224,3 +194,93 @@ getVersionR = selectRep $ do
       $(widgetFile "versionHistory")
     provideRep $
       return ($gitDescribe :: Text)
+
+
+
+
+data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+instance Universe HelpIdentOptions
+instance Finite HelpIdentOptions
+
+nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
+embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
+
+data HelpForm = HelpForm
+  { hfReferer:: Maybe (Route UniWorX)
+  , hfUserId :: Either (Maybe Address) UserId
+  , hfRequest:: Text
+  }
+
+helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
+helpForm mReferer mUid = HelpForm
+    <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
+    <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
+    <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
+    <*  submitButton
+  where
+    identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
+    identActions = Map.fromList $ case mUid of
+      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+      Nothing    -> defaultActions
+
+    defaultActions =
+      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
+      , (HIAnonymous, pure $ Left Nothing)
+      ]
+
+getHelpR, postHelpR :: Handler Html
+getHelpR = postHelpR
+postHelpR = do
+  mUid <- maybeAuthId
+  mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
+
+  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
+
+  formResultModal res HelpR $ \HelpForm{..} -> do
+    now <- liftIO getCurrentTime
+    hfReferer' <- traverse toTextUrl hfReferer
+    queueJob' JobHelpRequest
+      { jSender      = hfUserId
+      , jHelpRequest = hfRequest
+      , jRequestTime = now
+      , jReferer     = hfReferer'
+      }
+    tell . pure =<< messageI Success MsgHelpSent
+
+  defaultLayout $ do
+    setTitle "Hilfe" -- TODO: International
+    isModal <- hasCustomHeader HeaderIsModal
+    $(widgetFile "help")
+
+
+getAuthPredsR, postAuthPredsR :: Handler Html
+getAuthPredsR = postAuthPredsR
+postAuthPredsR = do
+  (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+
+  let
+    blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
+    taForm authTag
+      | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
+      | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
+
+  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
+    $ AuthTagActive
+      <$> (submitButton -- for convenience, avoids frequent scrolling
+      *>  funcForm taForm (fslI MsgActiveAuthTags) True)
+      <*  submitButton
+
+  mReferer <- runMaybeT $ do
+    param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
+    MaybeT . return $ fromPathPiece param
+  formResult authActiveRes $ \authTagActive -> do
+    setSessionJson SessionActiveAuthTags authTagActive
+    modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
+    addMessageI Success MsgAuthPredsActiveChanged
+    redirect $ fromMaybe AuthPredsR mReferer
+
+  defaultLayout $ do
+    setTitleI MsgAuthPredsActive
+    $(widgetFile "authpreds")

src/Handler/Profile.hs

@@ -1,17 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE MultiWayIf, LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Handler.Profile where
 
 import Import
@@ -37,6 +23,7 @@ data SettingsForm = SettingsForm
       , stgDate          :: DateTimeFormat
       , stgTime          :: DateTimeFormat
       , stgDownloadFiles :: Bool
+      , stgNotificationSettings :: NotificationSettings
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@@ -53,21 +40,25 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
+      <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
       <*  submitButton
     return (result, widget) -- no validation required here
+  where
+    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 
-
-getProfileR :: Handler Html
-getProfileR = do
+getProfileR, postProfileR :: Handler Html
+getProfileR = postProfileR
+postProfileR = do
   (uid, User{..}) <- requireAuthPair
-  let settingsTemplate = Just $ SettingsForm
+  let settingsTemplate = Just SettingsForm
         { stgMaxFavourties = userMaxFavourites
         , stgTheme         = userTheme
         , stgDateTime      = userDateTimeFormat
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
         , stgDownloadFiles = userDownloadFiles
+        , stgNotificationSettings = userNotificationSettings
         }
   ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
   case res of
@@ -79,146 +70,167 @@ getProfileR = do
                       , UserDateFormat     =. stgDate
                       , UserTimeFormat     =. stgTime
                       , UserDownloadFiles  =. stgDownloadFiles
+                      , UserNotificationSettings =. stgNotificationSettings
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size
             oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
                                       [ Desc CourseFavouriteTime
-                                      , OffsetBy $ stgMaxFavourties
+                                      , OffsetBy stgMaxFavourties
                                       ]
             mapM_ delete oldFavs
-        addMessageI Info $ MsgSettingsUpdate
+        addMessageI Info MsgSettingsUpdate
         redirect ProfileR -- TODO: them change does not happen without redirect
 
-    (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
+    (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
     _ -> return ()
 
-
-  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
-            (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
-                E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
-                E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
-                return (school E.^. SchoolShorthand)
-            )
-            <*>
-            (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
-                E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
-                E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
-                return (school E.^. SchoolShorthand)
-            )
-            <*>
-            (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
-                E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
-                E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-                E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
-                return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
-            )
-            <*>
-            (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-                E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
-                E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
-                E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                return  ( ( studydegree E.^. StudyDegreeName
-                          , studydegree E.^. StudyDegreeKey
-                          )
-                        , ( studyterms  E.^. StudyTermsName
-                          , studyterms  E.^. StudyTermsKey
-                          )
-                        , studyfeat   E.^. StudyFeaturesType
-                        , studyfeat   E.^. StudyFeaturesSemester)
-            )
-  let formText  = Just MsgSettings
+  let formText  = Nothing :: Maybe UniWorXMessage
       actionUrl = ProfileR
-      settingsForm = $(widgetFile "formPageI18n")
   defaultLayout $ do
     setTitle . toHtml $ userIdent <> "'s User page"
-    $(widgetFile "profile")
-    $(widgetFile "dsgvDisclaimer")
-
-postProfileR :: Handler Html
-postProfileR = do
-  -- TODO
-  getProfileR
+    $(widgetFile "formPageI18n")
 
 postProfileDataR  :: Handler Html
 postProfileDataR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm
+  ((btnResult,_), _) <- runFormPost buttonForm
   case btnResult of
     (FormSuccess BtnDelete) -> do
       (uid, User{..}) <- requireAuthPair
-      addMessage Warning "Delete-Knopf gedrückt"
-      addMessage Error "Löschen der Daten wurde noch nicht implementiert."
-      -- first determine all submission that solely depend on this user:
-      -- SubmissionGroup / SubmissionGroupUser
-      -- Submission / SubmissionUser
-      -- runDB $ deleteCascade uid
-    (FormSuccess BtnAbort ) -> do
-      addMessageI Info MsgAborted
-      redirect ProfileDataR
-    _other -> return ()
-  getProfileDataR
+      clearCreds False -- Logout-User
+      ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
+      -- addMessageIHamlet
+      $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
+      -- addMessageI Success $ MsgDeleteUser deletedSubmissions
+      -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
+      defaultLayout
+        $(widgetFile "deletedUser")
+
+    -- (FormSuccess BtnAbort ) -> do
+    --   addMessageI Info MsgAborted
+    --   redirect ProfileDataR
+    _other -> getProfileDataR
 
 
 
-getProfileDataR  :: Handler Html
+deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
+deleteUser duid = do
+    -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
+    -- We delete all files tied to submissions where the user is the lone submissionUser
+
+    -- Do not deleteCascade submissions where duid is the corrector:
+    updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
+
+    groupSubmissions  <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>.  E.val (0::Int64))
+    singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
+    deleteCascade duid
+    forM_ singleSubmissions $ \(E.Value submissionId) -> do
+      deleteFileIds  <- map E.unValue <$> getSubmissionFiles submissionId
+      deleteCascade submissionId
+      deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
+
+    deletedSubmissionGroups <- deleteSingleSubmissionGroups
+    return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
+  where
+    selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
+    selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
+        E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
+        let numBuddies = E.sub_select $ E.from $ \subUsers -> do
+                E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+                    E.&&.  subUsers E.^. SubmissionUserUser E.!=. E.val duid
+                return E.countRows
+        E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
+             E.&&. whereBuddies numBuddies
+        return $ submission E.^. SubmissionId
+
+    getSubmissionFiles :: SubmissionId ->  DB [E.Value (Key File)]
+    getSubmissionFiles subId = E.select $ E.from $ \file -> do
+      E.where_ $ E.exists $ E.from $ \submissionFile ->
+          E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
+              E.&&.  submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
+      return $ file E.^. FileId
+
+    deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
+      E.where_ $ E.exists $ E.from $ \subGroupUser ->
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
+      E.where_ $ E.notExists $ E.from $ \subGroupUser ->
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
+
+
+
+
+
+
+getProfileDataR :: Handler Html
 getProfileDataR = do
   (uid, User{..}) <- requireAuthPair
   --   mr <- getMessageRender
-  -- Tabelle mit eigenen Kursen
-  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-  -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
-  enrolledCoursesTable <- mkEnrolledCoursesTable uid
-  -- Tabelle mit allen Klausuren und Noten
-  examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-  -- Tabelle mit allen Abgaben und Abgabe-Gruppen
-  submissionTable <- mkSubmissionTable uid
-  -- Tabelle mit allen Abgabegruppen
-  submissionGroupTable <- mkSubmissionGroupTable uid
-  -- Tabelle mit allen Korrektor-Aufgaben
-  correctionsTable <- mkCorrectionsTable uid
-  -- Tabelle mit allen eigenen Tutorials
-  ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-  -- Tabelle mit allen Tutorials
-  tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
+    E.select
+      ( E.from $ \(adright `E.InnerJoin` school) -> do
+          E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
+          E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
+          return (school E.^. SchoolShorthand)
+      )
+    <*>
+    E.select
+      ( E.from $ \(lecright `E.InnerJoin` school) -> do
+          E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
+          E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
+          return (school E.^. SchoolShorthand)
+      )
+    <*>
+    E.select
+      ( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
+          E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+          E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+          E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
+          return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
+      )
+    <*>
+    E.select
+      ( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+          E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+          E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
+          E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+          return  ( ( studydegree E.^. StudyDegreeName
+                      , studydegree E.^. StudyDegreeKey
+                      )
+                  , ( studyterms  E.^. StudyTermsName
+                      , studyterms  E.^. StudyTermsKey
+                      )
+                  , studyfeat   E.^. StudyFeaturesType
+                  , studyfeat   E.^. StudyFeaturesSemester)
+      )
+  (   (hasRows, ownedCoursesTable)
+    , enrolledCoursesTable
+    , submissionTable
+    , submissionGroupTable
+    , correctionsTable
+    ) <- runDB $ (,,,,)
+           <$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+           <*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
+           <*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
+           <*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
+           <*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
+
+
+  let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
+  let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+  let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+
   -- Delete Button
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-  -- TODO: move this into a Message and/or Widget-File
-  let delWdgt = [whamlet|
-        <form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
-          <h2>
-            Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
-          <div .container>
-              Während der Testphase von Uni2work können Sie hiermit
-              Ihren Account bei Uni2work vollständig löschen.
-              Mit Ihrem Campus-Account können Sie sich aber danach
-              jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
-          <div .container>
-              Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
-              wenn die Dateien ausschließlich Ihnen zugeordnet sind.
-              Dateien aus Gruppenabgaben werden also erst dann gelöscht,
-              wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
-          <div .container>
-              <em>Achtung:
-              Auch abgegebene Hausübungen werden gelöscht!
-              Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
-              kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
-              (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
-              Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
-              auch nicht mehr rekonstruiert/berücksichtigt werden.)
-          <div .container>
-            <em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
-            eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
-            aufbewahrt werden müssen.
-          <div .container>
-            ^{btnWdgt}
-      |]
+  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
   defaultLayout $ do
+    let delWdgt = $(widgetFile "widgets/data-delete")
     $(widgetFile "profileData")
     $(widgetFile "dsgvDisclaimer")
 
 
 
-mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget)
+mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
 -- Table listing all courses that the given user is a lecturer for
 mkOwnedCoursesTable =
   let dbtIdent = "courseOwnership" :: Text
@@ -228,14 +240,15 @@ mkOwnedCoursesTable =
                -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
       withType = id
 
-      dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do
+      dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
           E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
           E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
           return ( course E.^. CourseTerm
                  , course E.^. CourseSchool
                  , course E.^. CourseShorthand
                  )
-      dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+      dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
+      dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
 
       dbtColonnade = mconcat
           [ dbRow
@@ -247,10 +260,10 @@ mkOwnedCoursesTable =
               schoolCell <$> view (_dbrOutput . _1 . re _Just)
                          <*> view (_dbrOutput . _2 )
           , sortable (Just "course") (i18nCell MsgCourse) $
-              courseCellCL <$> view (_dbrOutput)
+              courseCellCL <$> view _dbrOutput
           ]
 
-      validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
+      validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
       dbtSorting = Map.fromList
           [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
           , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm     )
@@ -261,18 +274,20 @@ mkOwnedCoursesTable =
           , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
           , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
           ]
-  in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..})
+      dbtFilterUI = mempty
+      dbtParams = def
+  in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
 
-mkEnrolledCoursesTable :: UserId -> Handler Widget
+mkEnrolledCoursesTable :: UserId -> DB Widget
 -- Table listing all courses that the given user is enrolled in
 mkEnrolledCoursesTable =
   let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
                -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
       withType = id
 
-      validator = def & defaultSorting [("time",SortDesc)]
+      validator = def & defaultSorting [SortDescBy "time"]
 
   in \uid -> dbTableWidget' validator
     DBTable
@@ -281,6 +296,7 @@ mkEnrolledCoursesTable =
           E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
           E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
           return (course, participant E.^. CourseParticipantRegistration)
+      , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
       , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
       , dbtColonnade = mconcat
           [ dbRow
@@ -288,7 +304,7 @@ mkEnrolledCoursesTable =
               termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
           , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
               schoolCell <$> view ( _courseTerm . re _Just)
-                          <*> view ( _courseSchool )
+                          <*> view  _courseSchool
           , sortable (Just "course") (i18nCell MsgCourse) $
               courseCell <$> view (_dbrOutput . _1 . _entityVal)
           , sortable (Just "time") (i18nCell MsgRegistered) $ do
@@ -307,12 +323,14 @@ mkEnrolledCoursesTable =
           , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
 --          , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
           ]
+      , dbtFilterUI  = mempty
       , dbtStyle     = def
+      , dbtParams = def
       }
 
 
 
-mkSubmissionTable :: UserId -> Handler Widget
+mkSubmissionTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionTable =
   let dbtIdent = "submissions" :: Text
@@ -322,18 +340,18 @@ mkSubmissionTable =
               ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
       withType = id
 
-      dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do
+      dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
         E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
         E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
         E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
         E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
-        let crse =  ( course E.^. CourseTerm
-                    , course E.^. CourseSchool
-                    , course E.^. CourseShorthand
-                    )
-        let sht  =  ( sheet E.^. SheetName
-                    )
+        let crse = ( course E.^. CourseTerm
+                   , course E.^. CourseSchool
+                   , course E.^. CourseShorthand
+                   )
+        let sht  = sheet E.^. SheetName
         return (crse, sht, submission, lastSubEdit uid submission)
+      dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
 
       lastSubEdit uid submission = -- latest Edit-Time of this user for submission
         E.sub_select . E.from $ \subEdit -> do
@@ -341,7 +359,7 @@ mkSubmissionTable =
               E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val uid
           return . E.max_ $ subEdit E.^. SubmissionEditTime
 
-      dbtProj = \x -> return $ x
+      dbtProj x = return $ x
         & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
         & _dbrOutput . _2 %~ E.unValue
         & _dbrOutput . _4 %~ E.unValue
@@ -352,7 +370,7 @@ mkSubmissionTable =
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view ( _1. re _Just)
-                        <*> view ( _2 )
+                        <*> view  _2
         , sortable (Just "course") (i18nCell MsgCourse) $
             courseCellCL <$> view (_dbrOutput . _1)
         , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
@@ -372,7 +390,7 @@ mkSubmissionTable =
       validator = def -- DUPLICATED CODE: Handler.Corrections
         & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
         & restrictSorting (\name _ -> name /= "corrector")
-        & defaultSorting [("edit",SortDesc)]
+        & defaultSorting [SortDescBy "edit"]
       dbtSorting' uid = Map.fromList
         [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
         , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm     )
@@ -385,16 +403,18 @@ mkSubmissionTable =
         , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         ]
+      dbtFilterUI = mempty
+      dbtParams = def
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
-              in  dbTableWidget' validator $ DBTable {..}
+              in  dbTableWidget' validator DBTable{..}
 --   in do dbtSQLQuery <- dbtSQLQuery'
 --         dbtSorting  <- dbtSorting'
 --         return $ dbTableWidget' validator $ DBTable {..}
 
 
 
-mkSubmissionGroupTable :: UserId -> Handler Widget
+mkSubmissionGroupTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionGroupTable =
   let dbtIdent = "subGroups" :: Text
@@ -403,7 +423,7 @@ mkSubmissionGroupTable =
               ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
       withType = id
 
-      dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do
+      dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
         E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
         E.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
         E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
@@ -412,6 +432,7 @@ mkSubmissionGroupTable =
                     , course E.^. CourseShorthand
                     )
         return (crse, sgroup, lastSGEdit sgroup)
+      dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
 
       lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
         E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
@@ -419,7 +440,7 @@ mkSubmissionGroupTable =
           E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
           return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
 
-      dbtProj = \x -> return $ x
+      dbtProj x = return $ x
         & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
         & _dbrOutput . _3 %~ E.unValue
 
@@ -429,7 +450,7 @@ mkSubmissionGroupTable =
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view ( _1. re _Just)
-                        <*> view ( _2 )
+                        <*> view _2
         , sortable (Just "course") (i18nCell MsgCourse) $
             courseCellCL <$> view (_dbrOutput . _1)
         , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
@@ -441,7 +462,7 @@ mkSubmissionGroupTable =
       validator = def -- DUPLICATED CODE: Handler.Corrections
         & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
         & restrictSorting (\name _ -> name /= "corrector")
-        & defaultSorting [("edit",SortDesc)]
+        & defaultSorting [SortDescBy "edit"]
       dbtSorting = Map.fromList
         [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
         , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm     )
@@ -454,12 +475,14 @@ mkSubmissionGroupTable =
         , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         ]
+      dbtFilterUI = mempty
+      dbtParams = def
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator $ DBTable {..}
+              in  dbTableWidget' validator DBTable{..}
 
 
 
-mkCorrectionsTable :: UserId -> Handler Widget
+mkCorrectionsTable :: UserId -> DB Widget
 -- Table listing sum of corrections made by the given user per sheet
 mkCorrectionsTable =
   let dbtIdent = "corrections" :: Text
@@ -472,15 +495,15 @@ mkCorrectionsTable =
       corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
               E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-          return $ E.countRows
+          return E.countRows
 
       corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
-              E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-              E.&&.  (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
-          return $ E.countRows
+               E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+               E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
+          return E.countRows
 
-      dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
+      dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
         E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
         E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
         E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
@@ -489,8 +512,9 @@ mkCorrectionsTable =
                     , course E.^. CourseShorthand
                     )
         return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
+      dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
 
-      dbtProj = \x -> return $ x
+      dbtProj x = return $ x
         & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
         & _dbrOutput . _2 %~ E.unValue
 
@@ -514,7 +538,7 @@ mkCorrectionsTable =
             int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
         ]
 
-      validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
+      validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
       dbtSorting = Map.fromList
         [ ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseTerm     )
         , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseSchool   )
@@ -527,6 +551,8 @@ mkCorrectionsTable =
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
         ]
+      dbtFilterUI = mempty
+      dbtParams = def
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator $ DBTable {..}
+              in  dbTableWidget' validator DBTable{..}
 

src/Handler/School.hs

@@ -1,53 +1,10 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.School where
 
 import Import
 
--- import Control.Lens
--- import Utils.Lens
--- import Utils.TH
--- import Handler.Utils
--- import Handler.Utils.Table.Cells
---
--- -- import Data.Time
--- import qualified Data.Text as T
--- import Data.Function ((&))
--- -- import Yesod.Form.Bootstrap3
---
--- import qualified Data.Set as Set
--- import qualified Data.Map as Map
---
--- import Colonnade hiding (fromMaybe,bool)
---
--- import qualified Database.Esqueleto as E
---
--- import qualified Data.UUID.Cryptographic as UUID
-
-
 getSchoolListR :: Handler Html
-getSchoolListR = do
-  -- muid <- maybeAuthId
-  defaultLayout $ do
-    [whamlet|TODO: Liste aller Institute |] -- TODO
-
+getSchoolListR = error "getSchoolListR: Not implemented"
 
 getSchoolShowR :: SchoolId -> Handler Html
-getSchoolShowR ssh = do -- TODO
-  -- muid <- maybeAuthId
-  defaultLayout $ do
-    [whamlet|TODO: Informationen zu einem Institut |] -- TODO
+getSchoolShowR = error "getSchoolShowR: Not implemented"
 

src/Handler/Sheet.hs

@@ -1,28 +1,14 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE MultiWayIf, LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-
 module Handler.Sheet where
 
 import Import
 import System.FilePath (takeFileName)
 
+import Utils.Sheet
 import Handler.Utils
 -- import Handler.Utils.Zip
 import Handler.Utils.Table.Cells
+import Handler.Utils.SheetType
+import Handler.Utils.Delete
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -48,24 +34,26 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 -- import qualified Data.List as List
 
+import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
+
 import Network.Mime
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import Data.Map (Map, (!), (!?))
-import qualified Data.Map as Map
+import Data.Map (Map, (!?))
 
-import Data.Monoid (Sum(..))
+import Data.Monoid (Any(..))
 
-import Control.Lens
--- import Utils.Lens
+-- import Control.Lens
+import Utils.Lens
 
+--import qualified Data.Aeson as Aeson
+
+import Control.Monad.Random.Class (MonadRandom(..))
+import Utils.Sql
 
-instance Eq (Unique Sheet) where
-  (CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
-    cid1 == cid2 && name1 == name2
 
 {-
   * Implement Handlers
@@ -78,10 +66,10 @@ data SheetForm = SheetForm
       , sfDescription  :: Maybe Html
       , sfType         :: SheetType
       , sfGrouping     :: SheetGroup
-      , sfMarkingText  :: Maybe Html
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
+      , sfSubmissionMode :: SheetSubmissionMode
       , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
@@ -89,6 +77,7 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
       , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
+      , sfMarkingText  :: Maybe Html
       -- Keine SheetId im Formular!
       }
 
@@ -110,9 +99,10 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType
+            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
+                                                          (sfType        <$> template)
       <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
-      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -120,6 +110,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
+      <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
       <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (Upload True))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
@@ -131,6 +122,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
             & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -148,6 +140,19 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo)   , render MsgSheetErrSolutionEarly)
       ] ]
 
+
+getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getSheetCurrentR tid ssh csh = runDB $ do
+  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
+  shn <- sheetCurrent tid ssh csh
+  maybe notFound redi shn
+
+getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
+getSheetOldUnassigned tid ssh csh = runDB $ do
+  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
+  shn <- sheetOldUnassigned tid ssh csh
+  maybe notFound redi shn
+
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetListR tid ssh csh = do
   muid <- maybeAuthId
@@ -156,26 +161,33 @@ getSheetListR tid ssh csh = do
     lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
         E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
         return . E.max_ $ sheetEdit E.^. SheetEditTime
-    sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
+
+    sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
     sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
       E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
       E.on $  (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
         E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-      return (sheet, lastSheetEdit sheet, submission)
+
+    sheetFilter :: SheetName -> DB Bool
+    sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
+
     sheetCol = widgetColonnade . mconcat $
-      [ sortable (Just "name") (i18nCell MsgSheet)
-          $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
+      [ dbRow
+      , sortable (Just "name") (i18nCell MsgSheet)
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
+          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime
+      , sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom)
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty timeCell sheetVisibleFrom
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
       , sortable Nothing (i18nCell MsgSubmission)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid -- TODO: executed twice
@@ -184,72 +196,101 @@ getSheetListR tid ssh csh = do
                       return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
                 in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
       , sortable (Just "rating") (i18nCell MsgRating)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
-              Nothing -> mempty
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} ->
+            let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
+            case mbSub of
+              Nothing -> cellTell mempty $ stats Nothing
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid
                     mkRoute = do
-                      cid <- mkCid
-                      return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
-                    protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
-                in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
+                      cid' <- mkCid
+                      return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
+                    acell = anchorCellM mkRoute $(widgetFile "widgets/rating")
+                in cellTell acell $ stats submissionRatingPoints
+
       , sortable Nothing -- (Just "percent")
                         (i18nCell MsgRatingPercent)
-          $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
-                case sType of
-                  NotGraded -> mempty
-                  _ | maxPoints sType > 0 ->
-                        let percent = sPoints / maxPoints sType
+                case preview (_grading . _maxPoints) sType of
+                  Just maxPoints
+                    | maxPoints /= 0 ->
+                        let percent = sPoints / maxPoints
                         in textCell $ textPercent $ realToFrac percent
                   _other -> mempty
               _other -> mempty
       ]
+
     psValidator = def
-      & defaultSorting [("submission-since", SortAsc)]
-  (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
-    { dbtSQLQuery  = sheetData
-    , dbtColonnade = sheetCol
-    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
-                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
-    , dbtSorting   = Map.fromList
-      [ ( "name"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
-        )
-      , ( "last-edit"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
-        )
-      , ( "submission-since"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
-        )
-      , ( "submission-until"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
-        )
-      , ( "rating"
-        , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
-        )
---    GitLab Issue $143: HOW TO SORT?
---       , ( "percent"
---         , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
---             case sheetType of -- no Haskell inside Esqueleto, right?
---             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
---         )
-      ]
-    , dbtFilter    = Map.fromList
-      []
-    , dbtStyle     = def
-    , dbtIdent     = "sheets" :: Text
-    }
+      & defaultSorting [SortDescBy "submission-since"]
+
+  (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
+      { dbtColonnade = sheetCol
+      , dbtSQLQuery  = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
+                          -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
+      , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
+      , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
+                    -> dbr <$ guardM (lift $ sheetFilter sheetName)
+      , dbtSorting   = Map.fromList
+        [ ( "name"
+          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+          )
+        , ( "last-edit"
+          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
+          )
+        , ( "visible-from"
+          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom
+          )
+        , ( "submission-since"
+          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
+          )
+        , ( "submission-until"
+          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
+          )
+        , ( "rating"
+          , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
+          )
+  --    GitLab Issue $143: HOW TO SORT?
+  --       , ( "percent"
+  --         , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
+  --             case sheetType of -- no Haskell inside Esqueleto, right?
+  --             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
+  --         )
+        ]
+      , dbtFilter    = mempty
+      , dbtFilterUI  = mempty
+      , dbtStyle     = def
+      , dbtParams    = def
+      , dbtIdent     = "sheets" :: Text
+      }
+    -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
+    --   -- Collect summary over all Sheets, not just the ones shown due to pagination:
+    --   do
+    --     rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
+    --       sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
+    --     flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
+    -- )
+
+  let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows
+        -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
   defaultLayout $ do
     $(widgetFile "sheetList")
-    $(widgetFile "widgets/sheetTypeSummary")
+
+data ButtonGeneratePseudonym = BtnGenerate
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonGeneratePseudonym
+instance Finite ButtonGeneratePseudonym
+
+nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
+
+instance Button UniWorX ButtonGeneratePseudonym where
+  btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
+  btnClasses BtnGenerate = [BCIsButton, BCDefault]
 
 -- Show single sheet
 getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSShowR tid ssh csh shn = do
-  entSheet <- runDB $ fetchSheet tid ssh csh shn
-  let sheet = entityVal entSheet
-      sid   = entityKey entSheet
+  Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
   -- without Colonnade
 --   fileNameTypes <- runDB $ E.select $ E.from $
 --     \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
@@ -263,41 +304,46 @@ getSShowR tid ssh csh shn = do
 --   let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
   -- with Colonnade
 
-  let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
+  let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
         -- Restrict to consistent rows that correspond to each other
         E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
-        E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+        E.on (sheetFile E.^. SheetFileSheet   E.==. sheet'    E.^. SheetId)
         -- filter to requested file
-        E.where_ $  sheet     E.^. SheetId      E.==. E.val sid
+        E.where_ $  sheet'    E.^. SheetId      E.==. E.val sid
               E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
         -- return desired columns
         return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
   let colonnadeFiles = widgetColonnade $ mconcat
-        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype
-        , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
-                                                           (\(E.Value fName,_,_) -> str2widget fName)
+        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
+        , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
+            (CSheetR tid ssh csh shn (SFileR fType fName))
+            (str2widget fName)
         , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
         ]
   let psValidator = def
-        & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  ((), fileTable) <- dbTable psValidator $ DBTable
+        & defaultSorting [SortAscBy "type", SortAscBy "path"]
+  (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery = fileData
+    , dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
                    -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
     , dbtStyle = def
-    , dbtFilter = Map.empty
+    , dbtFilter = mempty
+    , dbtFilterUI = mempty
     , dbtIdent = "files" :: Text
-    , dbtSorting = [ ( "type"
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
-                     )
-                   , ( "path"
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
-                     )
-                   , ( "time"
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
-                     )
-                   ]
+    , dbtSorting = Map.fromList
+      [ ( "type"
+        , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
+        )
+      , ( "path"
+        , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
+        )
+      , ( "time"
+        , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
+        )
+      ]
+    , dbtParams = def
     }
   (hasHints, hasSolution) <- runDB $ do
     hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
@@ -307,14 +353,46 @@ getSShowR tid ssh csh shn = do
   visibleFrom <-    traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom  sheet
   when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
     maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
+  mPseudonym <- runMaybeT $ do
+    uid <- MaybeT maybeAuthId
+    Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
+    return $ review _PseudonymText sheetPseudonymPseudonym
+  (generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
+    over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing
   defaultLayout $ do
     setTitleI $ MsgSheetTitle tid ssh csh shn
     sheetFrom    <-           formatTime SelFormatDateTime  $ sheetActiveFrom   sheet
     sheetTo      <-           formatTime SelFormatDateTime  $ sheetActiveTo     sheet
     hintsFrom    <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom     sheet
     solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
+    markingText  <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
     $(widgetFile "sheetShow")
 
+getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
+getSPseudonymR = postSPseudonymR
+postSPseudonymR tid ssh csh shn = do
+  uid <- requireAuthId
+  shId <- runDB $ fetchSheetId tid ssh csh shn
+  let
+    genPseudonym = do
+      inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
+        candidate <- liftIO getRandom
+        existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
+        case existing of
+          Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
+          Nothing
+            -> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
+      case inserted of
+        Right Nothing -> genPseudonym
+        Right (Just ps) -> return ps
+        Left ps -> return ps
+  ps <- genPseudonym
+  selectRep $ do
+    provideRep . return $ review _PseudonymText ps
+    provideJson ps
+    provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
+
+
 getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
 getSFileR tid ssh csh shn typ title = do
   results <- runDB $ E.select $ E.from $
@@ -333,7 +411,6 @@ getSFileR tid ssh csh shn typ title = do
         )
       -- return desired columns
       return $ (file E.^. FileTitle, file E.^. FileContent)
-  let mimeType = defaultMimeLookup $ pack title
   case results of
     [(E.Value fileTitle, E.Value fileContent)]
       | Just fileContent' <- fileContent -> do
@@ -348,32 +425,47 @@ getSFileR tid ssh csh shn typ title = do
 
 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetNewR tid ssh csh = do
+  parShn <- runInputGetResult $ iopt ciField "shn"
+  let searchShn sheet = case parShn of
+        (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
+        -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
+        _other -> return ()
   lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
       E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
       E.where_ $ course E.^. CourseTerm      E.==. E.val tid
           E.&&.  course E.^. CourseSchool    E.==. E.val ssh
           E.&&.  course E.^. CourseShorthand E.==. E.val csh
+      searchShn sheet
+      -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
+      --       E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+      --       return . E.max_ $ sheetEdit E.^. SheetEditTime
+      -- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
+      -- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
       E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
       E.limit 1
       return sheet
+  now <- liftIO getCurrentTime
   let template = case lastSheets of
-        ((Entity {entityVal=Sheet{..}}):_)  -> Just $ SheetForm
-          { sfName         = stepTextCounterCI sheetName
-          , sfDescription  = sheetDescription
-          , sfType         = sheetType
-          , sfGrouping     = sheetGrouping
-          , sfMarkingText  = sheetMarkingText
-          , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
-          , sfActiveFrom   = addOneWeek     sheetActiveFrom
-          , sfActiveTo     = addOneWeek     sheetActiveTo
-          , sfUploadMode   = sheetUploadMode
-          , sfSheetF       = Nothing
-          , sfHintFrom     = addOneWeek <$> sheetHintFrom
-          , sfHintF        = Nothing
-          , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
-          , sfSolutionF    = Nothing
-          , sfMarkingF     = Nothing
-          }
+        ((Entity {entityVal=Sheet{..}}):_)  ->
+          let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now
+          in Just $ SheetForm
+            { sfName         = stepTextCounterCI sheetName
+            , sfDescription  = sheetDescription
+            , sfType         = sheetType
+            , sfGrouping     = sheetGrouping
+            , sfVisibleFrom  = addTime <$> sheetVisibleFrom
+            , sfActiveFrom   = addTime     sheetActiveFrom
+            , sfActiveTo     = addTime     sheetActiveTo
+            , sfSubmissionMode = sheetSubmissionMode
+            , sfUploadMode   = sheetUploadMode
+            , sfSheetF       = Nothing
+            , sfHintFrom     = addTime <$> sheetHintFrom
+            , sfHintF        = Nothing
+            , sfSolutionFrom = addTime <$> sheetSolutionFrom
+            , sfSolutionF    = Nothing
+            , sfMarkingF     = Nothing
+            , sfMarkingText  = sheetMarkingText
+            }
         _other -> Nothing
   let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
         insertUnique $ newSheet
@@ -385,21 +477,19 @@ postSheetNewR = getSheetNewR
 
 getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSEditR tid ssh csh shn = do
-  (sheetEnt, sheetFileIds) <- runDB $ do
+  (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
     ent <- fetchSheet tid ssh csh shn
     fti <- getFtIdMap $ entityKey ent
     return (ent, fti)
-  let sid = entityKey sheetEnt
-  let oldSheet@(Sheet {..}) = entityVal sheetEnt
   let template = Just $ SheetForm
         { sfName         = sheetName
         , sfDescription  = sheetDescription
         , sfType         = sheetType
         , sfGrouping     = sheetGrouping
-        , sfMarkingText  = sheetMarkingText
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
+        , sfSubmissionMode = sheetSubmissionMode
         , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
@@ -407,6 +497,7 @@ getSEditR tid ssh csh shn = do
         , sfSolutionFrom = sheetSolutionFrom
         , sfSolutionF    = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
         , sfMarkingF     = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
+        , sfMarkingText  = sheetMarkingText
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
@@ -428,19 +519,22 @@ handleSheetEdit tid ssh csh msId template dbAction = do
       saveOkay <- runDB $ do
         actTime <- liftIO getCurrentTime
         cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+        oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
         let newSheet = Sheet
-              { sheetCourse       = cid
-              , sheetName         = sfName
-              , sheetDescription  = sfDescription
-              , sheetType         = sfType
-              , sheetGrouping     = sfGrouping
-              , sheetMarkingText  = sfMarkingText
-              , sheetVisibleFrom  = sfVisibleFrom
-              , sheetActiveFrom   = sfActiveFrom
-              , sheetActiveTo     = sfActiveTo
-              , sheetHintFrom     = sfHintFrom
-              , sheetSolutionFrom = sfSolutionFrom
-              , sheetUploadMode   = sfUploadMode
+              { sheetCourse         = cid
+              , sheetName           = sfName
+              , sheetDescription    = sfDescription
+              , sheetType           = sfType
+              , sheetGrouping       = sfGrouping
+              , sheetMarkingText    = sfMarkingText
+              , sheetVisibleFrom    = sfVisibleFrom
+              , sheetActiveFrom     = sfActiveFrom
+              , sheetActiveTo       = sfActiveTo
+              , sheetHintFrom       = sfHintFrom
+              , sheetSolutionFrom   = sfSolutionFrom
+              , sheetUploadMode     = sfUploadMode
+              , sheetSubmissionMode = sfSubmissionMode
+              , sheetAutoDistribute = fromMaybe False oldAutoDistribute
               }
         mbsid <- dbAction newSheet
         case mbsid of
@@ -472,31 +566,14 @@ handleSheetEdit tid ssh csh msId template dbAction = do
     $(widgetFile "formPageI18n")
 
 
-
-getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-getSDelR tid ssh csh shn = do
-  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
-  case result of
-    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
-    (FormSuccess BtnDelete) -> do
-      runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
-      -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
-      redirect $ CourseR tid ssh csh SheetListR
-    _other -> do
-      submissionno <- runDB $ do
-          sid <- fetchSheetId tid ssh csh shn
-          count [SubmissionSheet ==. sid]
-      let formTitle = MsgSheetDelHead tid ssh csh shn
-      let formText  = Just $ MsgSheetDelText submissionno
-      let actionUrl = CSheetR tid ssh csh shn SDelR
-      defaultLayout $ do
-        setTitleI $ MsgSheetTitle tid ssh csh shn
-        $(widgetFile "formPageI18n")
-
-postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-postSDelR = getSDelR
-
+getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSDelR = postSDelR
+postSDelR tid ssh csh shn = do
+  sid <- runDB $ fetchSheetId tid ssh csh shn
+  deleteR $ (sheetDeleteRoute $ Set.singleton sid)
+    { drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
+    , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
+    }
 
 
 insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
@@ -556,20 +633,20 @@ defaultLoads shid = do
     toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
+correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
 correctorForm shid = do
   cListIdent <- newFormIdent
   let
     guardNonDeleted :: UserId -> Handler (Maybe UserId)
     guardNonDeleted uid = do
-      cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
+      CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
       deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
       return $ bool Just (const Nothing) (isJust deleted) uid
   formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
   let
     currentLoads :: DB Loads
     currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
-  (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+  (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
   loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
     , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
@@ -581,10 +658,11 @@ correctorForm shid = do
       didDelete = any (flip Set.member deletions) formCIDs
 
   (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
+  (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
   let
     tutorField :: Field Handler [UserEmail]
     tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
-      { fieldView = \theId name attrs val isReq -> asWidgetT $ do
+      { fieldView = \theId name attrs _val isReq -> asWidgetT $ do
           listIdent <- newIdent
           userId <- handlerToWidget requireAuthId
           previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
@@ -624,14 +702,14 @@ correctorForm shid = do
   let
     constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
     constructFields (uid, uname, (state, Load{..})) = do
-      cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
+      CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
       let
         fs name = ""
           { fsName = Just $ tshow ciphertext <> "-" <> name
           }
         rationalField = convertField toRational fromRational doubleField
 
-      (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state)
+      (stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
       (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
       (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
       (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
@@ -674,23 +752,25 @@ correctorForm shid = do
       cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
       toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
 
-  return (corrResults, [ countTutView
-                       , FieldView
-                           { fvLabel = text $ mr MsgCorrectors
-                           , fvTooltip = Nothing
-                           , fvId = ""
-                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
-                           , fvErrors = Nothing
-                           , fvRequired = True
-                           }
-                       , addTutView
-                           { fvInput = [whamlet|
-                               <div>
-                                 ^{fvInput addTutView}
-                                 <button type=submit formnovalidate data-formnorequired>Hinzufügen
-                             |]
-                           }
-                       ])
+  return ( (,) <$> autoDistributeRes <*> corrResults
+         , [ autoDistributeView
+           , countTutView
+           , FieldView
+             { fvLabel = text $ mr MsgCorrectors
+             , fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
+             , fvId = ""
+             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
+             , fvErrors = Nothing
+             , fvRequired = True
+             }
+           , addTutView
+             { fvInput = [whamlet|
+                           <div>
+                             ^{fvInput addTutView}
+                             <button type=submit formnovalidate data-formnorequired>Hinzufügen
+                         |]
+             }
+           ])
 
   -- Eingabebox für Korrektor hinzufügen
   -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
@@ -704,9 +784,10 @@ getSCorrR tid ssh csh shn = do
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-    FormSuccess res -> runDB $ do
+    FormSuccess (autoDistribute, res') -> runDB $ do
+      update shid [ SheetAutoDistribute =. autoDistribute ]
       deleteWhere [SheetCorrectorSheet ==. shid]
-      insertMany_ $ Set.toList res
+      insertMany_ $ Set.toList res'
       addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 

src/Handler/Submission.hs

@@ -1,28 +1,14 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE MultiWayIf #-}
-
 module Handler.Submission where
 
-import Import hiding (joinPath)
+import Import
 
--- import Yesod.Form.Bootstrap3  
+import Jobs
+
+-- import Yesod.Form.Bootstrap3
 
 import Handler.Utils
+import Handler.Utils.Delete
+import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 
 import Network.Mime
@@ -34,7 +20,6 @@ import Network.Mime
 import Data.Monoid (Any(..))
 import Data.Maybe (fromJust)
 -- import qualified Data.Maybe
-import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Data.CaseInsensitive (CI)
@@ -63,22 +48,27 @@ import System.FilePath
 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
-makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
+makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
+makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
     let
-      fileUpload = case uploadMode of
+      fileUploadForm = case uploadMode of
         NoUpload -> pure Nothing
         (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
     flip (renderAForm FormStandard) html $ (,)
-      <$> fileUpload
-      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
-                                    | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
-                                    | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
-                                    ])
+      <$> fileUploadForm
+      <*> ( (:|)
+        -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
+        <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
+        <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
+                                      | g <- [2..(fromIntegral groupNr)]
+                                      | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
+                                      ])
+        )
       <*  submitButton
   where
     (groupNr, editableBuddies)
-      | Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
+      | Arbitrary{..} <- grouping = (maxParticipants, True)
+      | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
       | otherwise = (0, False)
 
     aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
@@ -104,14 +94,14 @@ getSubmissionOwnR tid ssh csh shn = do
            E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
       return $ submission E.^. SubmissionId
     case submissions of
-      ((E.Value sid):_) -> return sid
+      (E.Value sid : _) -> return sid
       []      -> notFound
   cID <- encrypt sid
   redirect $ CSubmissionR tid ssh csh shn cID SubShowR
 
 submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
 submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
-  uid       <- requireAuthId
+  (Entity uid userData) <- requireAuth
   msmid     <- traverse decrypt mcid
   actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
   maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
@@ -125,7 +115,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           E.where_ $ submissionUser E.^. SubmissionUserUser   E.==. E.val uid
                E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
           return $ submission E.^. SubmissionId
-        -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
+        -- logDebugS "Submission.DUPLICATENEW" (tshow submissions)
         case submissions of
           []    -> do
             -- fetch buddies from previous submission in this course
@@ -147,23 +137,25 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             return (csheet, map E.unValue buddies, [])
           (E.Value smid:_) -> do
             cID <- encrypt smid
-            addMessageI Info $ MsgSubmissionAlreadyExists
+            addMessageI Info MsgSubmissionAlreadyExists
             redirect $ CSubmissionR tid ssh csh shn cID SubShowR
       (Just smid) -> do
         void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
-        
+
         shid' <- submissionSheet <$> get404 smid
+        unless (shid == shid') $
+          invalidArgsI [MsgSubmissionWrongSheet]
         -- fetch buddies from current submission
         (Any isOwner, buddies) <- do
-          submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+          submitters <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
             E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
             E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
             E.orderBy  [E.asc $ user E.^. UserEmail]
-            return $ (user E.^. UserId, user E.^. UserEmail)
+            return (user E.^. UserId, user E.^. UserEmail)
           let breakUserFromBuddies (E.Value userID, E.Value email)
                 | uid == userID  =  (Any True ,      [])
                 | otherwise      =  (Any False, [email])
-          return $ foldMap breakUserFromBuddies submittors
+          return $ foldMap breakUserFromBuddies submitters
 
         lastEdits <- do
             raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
@@ -174,17 +166,18 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               let userName = if isOwner || maySubmit
                               then E.just $ user E.^. UserDisplayName
                               else E.nothing
-              return $ (userName, submissionEdit E.^. SubmissionEditTime)
+              return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits)
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
-  mCID <- runDB $ do
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
+  mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
     res' <- case res of
-      (FormMissing )           -> return $ FormMissing
+      FormMissing              -> return   FormMissing
       (FormFailure failmsgs)   -> return $ FormFailure failmsgs
-      (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
-      (FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
-        | (Arbitrary {..}) <- sheetGrouping -> do
+      -- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students)
+      (FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change
+      (FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members
+        | Arbitrary{..} <- sheetGrouping -> do
           -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
           let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
               prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
@@ -201,7 +194,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                      E.&&. submission E.^. SubmissionSheet E.==. E.val shid
                 case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
                   Nothing   -> return ()
-                  Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid 
+                  Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
                 return $ E.countRows E.>. E.val (0 :: Int64)
             return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
 
@@ -215,7 +208,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                   (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
                   (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
                   _other             -> mempty
-              , case length participants `compare` maxParticipants of
+              , case fromIntegral (length participants) `compare` maxParticipants of
                   LT -> mempty
                   _  -> pure $ mr MsgTooManyParticipants
               ]
@@ -226,14 +219,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
 
 
     case res' of
-      (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
-        now <- liftIO $ getCurrentTime
+      (FormSuccess (mFiles, setFromList -> adhocIds)) -> do
         smid <- do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
-            (Just files, _)  -- new files
-              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+            (Just files, _) -> -- new files
+              runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             (Nothing, Nothing) -- new submission, no file upload requested
               -> insert Submission
                   { submissionSheet = shid
@@ -261,7 +253,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
         return $ Just cID
       (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
       _other -> return Nothing
-  
+
   case mCID of
     Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
     Nothing  -> return ()
@@ -276,13 +268,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               Just isFile = origIsFile <|> corrIsFile
             in if
               | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
-                                                      ([whamlet|#{fileTitle'}|])
+                                                      [whamlet|#{fileTitle'}|]
               | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
         , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
             Nothing -> cell mempty
             Just (_, Entity _ File{..})
               | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
-                                                 ([whamlet|_{MsgFileCorrected}|])
+                                                 [whamlet|_{MsgFileCorrected}|]
               | otherwise -> i18nCell MsgCorrected
         , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
               origTime = fileModified . entityVal . snd <$> mOrig
@@ -290,7 +282,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
             in timeCell fileTime
         ]
-      coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))   
+      coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
       coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
       submissionFiles :: _ -> _ -> E.SqlQuery _
       submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
@@ -307,20 +299,24 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
         return ((sf1, f1), (sf2, f2))
       smid2ArchiveTable (smid,cid) = DBTable
         { dbtSQLQuery = submissionFiles smid
+        , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
         , dbtColonnade = colonnadeFiles cid
         , dbtProj = return . dbrOutput
         , dbtStyle = def
         , dbtIdent = "files" :: Text
-        , dbtSorting =  [ ( "path"
-                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
-                          )
-                        , ( "time"
-                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
-                          )
-                        ]
-        , dbtFilter = []
+        , dbtSorting = Map.fromList
+          [ ( "path"
+            , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
+            )
+          , ( "time"
+            , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
+            )
+          ]
+        , dbtFilter = mempty
+        , dbtFilterUI = mempty
+        , dbtParams = def
         }
-  mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+  mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
@@ -330,58 +326,56 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
 
 
 getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
-getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
-  runDB $ do
-    submissionID <- submissionMatchesSheet tid ssh csh shn cID
+getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
+  submissionID <- submissionMatchesSheet tid ssh csh shn cID
 
-    isRating <- maybe False (== submissionID) <$> isRatingFile path
+  isRating <- (== Just submissionID) <$> isRatingFile path
 
-    when (isUpdate || isRating) $
-      guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
-  
-    case isRating of
-      True
-        | isUpdate -> do
-            file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
-            maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
-        | otherwise -> notFound
-      False -> do
-        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-               E.&&. f E.^. FileTitle E.==. E.val path
-               E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
-               E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-               -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
-          return f
+  when (isUpdate || isRating) $
+    guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
 
-        let fileName = Text.pack $ takeFileName path
-        case results of
-          [Entity _ File{ fileContent = Just c, fileTitle }] -> do
-            whenM downloadFiles $ 
-              addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
-            return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
-          [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
-          other -> do
-            $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
-            error "Multiple matching files found."
+  case isRating of
+    True
+      | isUpdate -> do
+          file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
+          maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+      | otherwise -> notFound
+    False -> do
+      results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+        E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+        E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+             E.&&. f E.^. FileTitle E.==. E.val path
+             E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
+             E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+             -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
+        return f
+
+      case results of
+        [Entity _ File{ fileContent = Just c, fileTitle }] -> do
+          whenM downloadFiles $
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
+        [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
+        other -> do
+          $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
+          error "Multiple matching files found."
 
 getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
 getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
-  when (sfType == SubmissionCorrected) $ 
+  when (sfType == SubmissionCorrected) $
     guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
 
   let filename
         | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
         | otherwise = ZIPArchiveName $ toPathPiece cID
-  
+
   addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
   respondSourceDB "application/zip" $ do
     submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
     rating <- lift $ getRating submissionID
 
     let
-      fileSource = case sfType of
+      fileSelect = case sfType of
         SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
           E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
           E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
@@ -390,10 +384,19 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
         _ -> submissionFileSource submissionID
 
       fileSource' = do
-        fileSource .| Conduit.map entityVal
+        fileSelect .| Conduit.map entityVal
         when (sfType == SubmissionCorrected) $
           maybe (return ()) (yieldM . ratingFile cID) rating
 
       zipComment = Text.encodeUtf8 $ toPathPiece cID
 
     fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+
+getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSubDelR = postSubDelR
+postSubDelR tid ssh csh shn cID = do
+  subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID
+  deleteR $ (submissionDeleteRoute $ Set.singleton subId)
+    { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
+    , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
+    }

src/Handler/SystemMessage.hs

@@ -0,0 +1,268 @@
+module Handler.SystemMessage where
+
+import Import
+
+import qualified Data.Map.Lazy as Map
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+
+import qualified Data.List.NonEmpty as NonEmpty
+
+import Handler.Utils
+
+import Utils.Lens
+
+import qualified Database.Esqueleto as E
+
+  
+htmlField' :: Field (HandlerT UniWorX IO) Html
+htmlField' = htmlField
+  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
+  }
+
+ 
+
+getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
+getMessageR = postMessageR
+postMessageR cID = do
+  smId <- decrypt cID
+  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
+  let (summary, content) = case translation of
+        Nothing -> (systemMessageSummary, systemMessageContent)
+        Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+
+  let
+    mkForm = do
+      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
+        $ SystemMessage
+          <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
+          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
+          <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
+          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
+          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
+          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
+          <* submitButton
+
+      ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
+      let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
+
+      modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
+        cID' <- encrypt tId
+        runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
+          $ (,)
+          <$> fmap (Entity tId)
+              ( SystemMessageTranslation
+                  <$> pure systemMessageTranslationMessage
+                  <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
+                  <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
+                  <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
+              )
+          <*> combinedButtonFieldF ""
+
+      let modifyTranss = Map.map (view $ _1._1) modifyTranss'
+
+      ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
+        $ SystemMessageTranslation
+          <$> pure smId
+          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
+          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
+          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
+          <* submitButton
+
+      formResult modifyRes $ modifySystemMessage smId
+
+      formResult addTransRes addTranslation
+
+      forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
+        [BtnDelete'] -> do
+          runDB $ delete tId
+          addMessageI Success MsgSystemMessageDeleteTranslationSuccess
+          redirect $ MessageR cID
+        _other -> do
+          runDB $ update tId
+            [ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage
+            , SystemMessageTranslationContent =. systemMessageTranslationContent
+            , SystemMessageTranslationSummary =. systemMessageTranslationSummary
+            ]
+          addMessageI Success MsgSystemMessageEditTranslationSuccess
+          redirect $ MessageR cID
+  
+      let
+        messageEditModal = modal [whamlet|_{MsgSystemMessageEdit}|] $ Right
+          [whamlet|
+            <form method=post action=@{MessageR cID} enctype=#{modifyEnctype}>
+              ^{modifyView}
+          |]
+        translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] $ Right
+          [whamlet|
+            <form method=post action=@{MessageR cID} enctype=#{addTransEnctype}>
+              ^{addTransView}
+          |]
+        translationsEditModal
+          | not $ null modifyTranss' = modal [whamlet|_{MsgSystemMessageEditTranslations}|] $ Right
+            [whamlet|
+              $forall ((_, transView), transEnctype) <- modifyTranss'
+                <section>
+                  <form method=post action=@{MessageR cID} enctype=#{transEnctype}>
+                    ^{transView}
+            |]
+          | otherwise = mempty
+      return (messageEditModal, translationAddModal, translationsEditModal)
+
+  maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
+  forms <- traverse (const mkForm) $ () <$ guard maySubmit
+  
+  defaultLayout
+    $(widgetFile "system-message")
+  where
+    modifySystemMessage smId SystemMessage{..} = do
+      runDB $ update smId
+        [ SystemMessageFrom =. systemMessageFrom
+        , SystemMessageTo =. systemMessageTo
+        , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
+        , SystemMessageSeverity =. systemMessageSeverity
+        , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
+        , SystemMessageContent =. systemMessageContent
+        , SystemMessageSummary =. systemMessageSummary
+        ]
+      addMessageI Success MsgSystemMessageEditSuccess
+      redirect $ MessageR cID
+
+    addTranslation translation = do
+      runDB . void $ insert translation
+      addMessageI Success MsgSystemMessageAddTranslationSuccess
+      redirect $ MessageR cID
+
+type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)
+
+data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
+  deriving (Eq, Ord, Enum, Bounded, Show, Read)
+instance Universe ActionSystemMessage
+instance Finite ActionSystemMessage
+
+nullaryPathPiece ''ActionSystemMessage (camelToPathPiece' 1)
+embedRenderMessage ''UniWorX ''ActionSystemMessage (("SystemMessage" <>) . dropPrefix "SM")
+
+data ActionSystemMessageData = SMDDelete
+                             | SMDActivate (Maybe UTCTime)
+                             | SMDDeactivate (Maybe UTCTime)
+  deriving (Eq, Show, Read)
+
+getMessageListR, postMessageListR :: Handler Html
+getMessageListR = postMessageListR
+postMessageListR = do
+  let
+    dbtSQLQuery = return
+    dbtColonnade = mconcat
+      [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
+      , dbRow
+      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
+      , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
+      , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
+      , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
+      , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
+      , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
+          (summary, content) = case smT of
+              Nothing -> (systemMessageSummary, systemMessageContent)
+              Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+            in cell . toWidget $ fromMaybe content summary
+      ]
+    dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
+      Just (_, smT) <- lift $ getSystemMessage appLanguages smId
+      return DBRow
+        { dbrOutput = (smE, smT)
+        , ..
+        }
+    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
+  (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
+    { dbtSQLQuery
+    , dbtRowKey = (E.^. SystemMessageId)
+    , dbtColonnade
+    , dbtProj
+    , dbtSorting = Map.fromList
+      [ ( "from"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
+        )
+      , ( "to"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
+        )
+      , ( "authenticated"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
+        )
+      , ( "severity"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
+        )
+      ]
+    , dbtFilter = mempty
+    , dbtFilterUI = mempty
+    , dbtStyle = def
+    , dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Just $ SomeRoute MessageListR
+      , dbParamsFormAttrs = []
+      , dbParamsFormAddSubmit = True
+      , dbParamsFormAdditional = \frag -> do
+          now <- liftIO getCurrentTime
+          let actions = Map.fromList
+                [ (SMDelete, pure SMDDelete)
+                , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
+                , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
+                ]
+          (actionRes, action) <- multiAction actions (Just SMActivate)
+          return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
+      , dbParamsFormEvaluate = liftHandlerT . runFormPost
+      , dbParamsFormResult = id
+      }
+    , dbtIdent = "messages" :: Text
+    }
+
+  let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
+                           & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
+
+  case tableRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess (SMDDelete, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ]
+          $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
+          redirect MessageListR
+    FormSuccess (SMDActivate ts, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
+          $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
+          redirect MessageListR
+    FormSuccess (SMDDeactivate ts, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
+          $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
+          redirect MessageListR
+    FormSuccess (_, _selection) -- prop> null _selection
+      -> addMessageI Error MsgSystemMessageEmptySelection
+
+  ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
+    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
+    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
+    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
+    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
+    <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
+    <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
+    <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
+    <* submitButton
+
+  case addRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess sysMsg -> do
+      sId <- runDB $ insert sysMsg
+      cID <- encrypt sId :: Handler CryptoUUIDSystemMessage
+      addMessageI Success $ MsgSystemMessageAdded cID
+      redirect $ MessageR cID
+
+  defaultLayout
+    $(widgetFile "system-message-list")

src/Handler/Term.hs

@@ -1,19 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude
-           , OverloadedStrings
-           , OverloadedLists
-           , RecordWildCards
-           , TemplateHaskell
-           , QuasiQuotes
-           , MultiParamTypeClasses
-           , TypeFamilies
-           , FlexibleContexts
-           , PartialTypeSignatures
-  #-}
-
 module Handler.Term where
 
 import Import
 import Handler.Utils
+import qualified Data.Map as Map
 
 -- import qualified Data.Text as T
 import Yesod.Form.Bootstrap3
@@ -21,10 +10,17 @@ import Yesod.Form.Bootstrap3
 
 import qualified Database.Esqueleto as E
 
+-- | Default start day of term for season,
+--   @True@: start of term, @False@: end of term
+defaultDay :: Bool -> Season -> Day
+defaultDay True  Winter = fromGregorian 2020 10  1
+defaultDay False Winter = fromGregorian 2020  3 31
+defaultDay True  Summer = fromGregorian 2020  4  1
+defaultDay False Summer = fromGregorian 2020  9 30
 
 
 validateTerm :: Term -> [Text]
-validateTerm (Term{..}) =
+validateTerm Term{..} =
   [ msg  | (False, msg) <-
     [ --startOk
       ( termStart `withinTerm` termName
@@ -71,15 +67,15 @@ getTermShowR = do
     provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
     provideRep $ do
       let colonnadeTerms = widgetColonnade $ mconcat
-            [ sortable Nothing "Kürzel" $
-                anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
-                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
+            [ sortable Nothing "Kürzel" $ \(Entity tid _, _) -> anchorCell
+                (TermCourseListR tid)
+                [whamlet|#{toPathPiece tid}|]
             , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                 cell $ formatTime SelFormatDate termLectureStart >>= toWidget
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
                 cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
             , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
-                textCell $ (bool "" tickmark termActive :: Text)
+                textCell (bool "" tickmark termActive :: Text)
             , sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
                 cell [whamlet|_{MsgNumCourses numCourses}|]
             , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
@@ -107,35 +103,40 @@ getTermShowR = do
 --                       #{termToText termName}
 --                 |]
 --           ]
-      ((), table) <- dbTable def $ DBTable
+      table <- runDB $ dbTableWidget' def DBTable
         { dbtSQLQuery = termData
+        , dbtRowKey = (E.^. TermId)
         , dbtColonnade = colonnadeTerms
         , dbtProj = return . dbrOutput
-        , dbtSorting = [ ( "start"
-                         , SortColumn $ \term -> term E.^. TermStart
-                         )
-                       , ( "end"
-                         , SortColumn $ \term -> term E.^. TermEnd
-                         )
-                       , ( "lecture-start"
-                         , SortColumn $ \term -> term E.^. TermLectureStart
-                         )
-                       , ( "lecture-end"
-                         , SortColumn $ \term -> term E.^. TermLectureEnd
-                         )
-                       ]
-        , dbtFilter = [ ( "active"
-                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
-                        )
-                      , ( "course"
-                        , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
-                            []   -> E.val True :: E.SqlExpr (E.Value Bool)
-                            cshs -> E.exists . E.from $ \course -> do
-                              E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
-                                   E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
-                        )
-                      ]
+        , dbtSorting = Map.fromList
+            [ ( "start"
+              , SortColumn $ \term -> term E.^. TermStart
+              )
+            , ( "end"
+              , SortColumn $ \term -> term E.^. TermEnd
+              )
+            , ( "lecture-start"
+              , SortColumn $ \term -> term E.^. TermLectureStart
+              )
+            , ( "lecture-end"
+              , SortColumn $ \term -> term E.^. TermLectureEnd
+              )
+            ]
+        , dbtFilter = Map.fromList
+            [ ( "active"
+              , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
+              )
+            , ( "course"
+              , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
+                  []   -> E.val True :: E.SqlExpr (E.Value Bool)
+                  cshs -> E.exists . E.from $ \course ->
+                    E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
+                         E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
+              )
+            ]
+        , dbtFilterUI = mempty
         , dbtStyle = def
+        , dbtParams = def
         , dbtIdent = "terms" :: Text
         }
       defaultLayout $ do
@@ -144,19 +145,31 @@ getTermShowR = do
 
 getTermEditR :: Handler Html
 getTermEditR = do
-  -- TODO: Defaults für Semester hier ermitteln und übergeben
-  termEditHandler Nothing
+  mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
+  let template = case mbLastTerm of
+        Nothing -> mempty
+        (Just (Entity { entityVal=Term{..} })) -> let
+            ntid = succ termName
+            seas = season ntid
+            yr   = year   ntid
+            yr'  = if seas == Summer then yr else succ yr
+          in mempty
+              { tftName  = Just $ ntid
+              , tftStart = Just $ defaultDay True  seas & setYear yr
+              , tftEnd   = Just $ defaultDay False seas & setYear yr'
+              }
+  termEditHandler template
 
 postTermEditR :: Handler Html
-postTermEditR = termEditHandler Nothing
+postTermEditR = termEditHandler mempty
 
 getTermEditExistR :: TermId -> Handler Html
 getTermEditExistR tid = do
   term <- runDB $ get tid
-  termEditHandler term
+  termEditHandler $ termToTemplate term
 
 
-termEditHandler :: Maybe Term -> Handler Html
+termEditHandler :: TermFormTemplate -> Handler Html
 termEditHandler term = do
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
@@ -171,24 +184,70 @@ termEditHandler term = do
 -- MIT INTERNATIONALISIERUNG:
           addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
-      (FormMissing  ) -> return ()
+      FormMissing     -> return ()
       (FormFailure _) -> addMessageI Warning MsgInvalidInput
     let actionUrl   = TermEditR
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       $(widgetFile "formPage")
 
-newTermForm :: Maybe Term -> Form Term
+data TermFormTemplate = TermFormTemplate
+      { tftName         :: Maybe TermIdentifier
+      , tftStart        :: Maybe Day
+      , tftEnd          :: Maybe Day
+      , tftHolidays     :: Maybe [Day]
+      , tftLectureStart :: Maybe Day
+      , tftLectureEnd   :: Maybe Day
+      , tftActive       :: Maybe Bool
+      }
+
+-- | TermFormTemplates form a pointwise-left biased Semigroup
+instance Semigroup TermFormTemplate where
+  left <> right = TermFormTemplate
+    { tftName         = tftName         left <|> tftName         right
+    , tftStart        = tftStart        left <|> tftStart        right
+    , tftEnd          = tftEnd          left <|> tftEnd          right
+    , tftHolidays     = tftHolidays     left <|> tftHolidays     right
+    , tftLectureStart = tftLectureStart left <|> tftLectureStart right
+    , tftLectureEnd   = tftLectureEnd   left <|> tftLectureEnd   right
+    , tftActive       = tftActive       left <|> tftActive       right
+    }
+
+instance Monoid TermFormTemplate where
+  mappend = (<>)
+  mempty  = TermFormTemplate
+    { tftName         = Nothing
+    , tftStart        = Nothing
+    , tftEnd          = Nothing
+    , tftHolidays     = Nothing
+    , tftLectureStart = Nothing
+    , tftLectureEnd   = Nothing
+    , tftActive       = Nothing
+    }
+
+termToTemplate ::Maybe Term -> TermFormTemplate
+termToTemplate Nothing = mempty
+termToTemplate (Just Term{..}) = TermFormTemplate
+    { tftName         = Just termName
+    , tftStart        = Just termStart
+    , tftEnd          = Just termEnd
+    , tftHolidays     = Just termHolidays
+    , tftLectureStart = Just termLectureStart
+    , tftLectureEnd   = Just termLectureEnd
+    , tftActive       = Just termActive
+    }
+
+newTermForm :: TermFormTemplate -> Form Term
 newTermForm template html = do
     mr <- getMessageRender
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName  <$> template)
-      <*> areq dayField  (fsl ("Erster Tag" :: Text)) (termStart <$> template)
-      <*> areq dayField  (fsl ("Letzer Tag" :: Text)) (termEnd   <$> template)
+      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
+      <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
+      <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
       <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
-      <*> areq dayField  (fsl "Beginn Vorlesungen") (termLectureStart <$> template)
-      <*> areq dayField  (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd   <$> template)
-      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
+      <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
+      <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
+      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
       <*  submitButton
     return $ case result of
       FormSuccess termResult

src/Handler/Users.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-
 module Handler.Users where
 
 import Import
@@ -17,18 +9,16 @@ import Utils.Lens
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
 
 
-hijackUserForm :: UserId -> Form UserId
-hijackUserForm uid csrf = do
-  cID <- encrypt uid
+hijackUserForm :: CryptoUUIDUser -> Form ()
+hijackUserForm cID csrf = do
   (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
   (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing 
 
-  return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
+  return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
 
 getUsersR :: Handler Html
 getUsersR = do
@@ -67,18 +57,22 @@ getUsersR = do
                 <li>#{sh}
             |]
       , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
-          (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
           cID <- encrypt uid
-          [whamlet|
-            <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
-              ^{hijackView}
-          |]
+          mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
+          myUid <- liftHandlerT maybeAuthId
+          when (mayHijack && Just uid /= myUid) $ do
+            (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
+            [whamlet|
+              <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+                ^{hijackView}
+            |]
       ]
     psValidator = def
-      & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
+      & defaultSorting [SortAscBy "name", SortAscBy "display-name"]
   
-  ((), userList) <- dbTable psValidator $ DBTable
+  ((), userList) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
+    , dbtRowKey = (E.^. UserId)
     , dbtColonnade
     , dbtProj      = return
     , dbtSorting   = Map.fromList
@@ -93,7 +87,9 @@ getUsersR = do
           )
         ]
     , dbtFilter    = mempty
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
+    , dbtParams    = def
     , dbtIdent     = "users" :: Text
     }
   
@@ -104,21 +100,10 @@ getUsersR = do
 postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
 postAdminHijackUserR cID = do
   uid <- decrypt cID
-  ((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
+  ((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
 
-  case hijackRes of
-    FormSuccess uid'
-      | uid' == uid -> do
-          myUid <- requireAuthId
-          User{..} <- runDB $ do
-            otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
-            otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
-            mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
-            when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
-              permissionDenied "Cannot escalate admin status to additional schools"
+  ret <- formResultMaybe hijackRes $ \() -> Just <$> do
+    User{userIdent} <- runDB $ get404 uid
+    setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
 
-            get404 uid
-          setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
-      | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
-    FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
-    FormMissing -> return $ toTypedContent ()
+  maybe (redirect UsersR) return ret

src/Handler/Utils.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-
-
 module Handler.Utils
   ( module Handler.Utils
   ) where
@@ -22,9 +15,10 @@ import Handler.Utils.Table.Pagination as Handler.Utils
 
 import Handler.Utils.Zip        as Handler.Utils
 import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
-import Handler.Utils.Submission as Handler.Utils
+-- import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils
+import Handler.Utils.Mail       as Handler.Utils
 
 
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
@@ -37,22 +31,25 @@ downloadFiles = do
       return userDefaultDownloadFiles
 
 tidFromText :: Text -> Maybe TermId
-tidFromText = (fmap TermKey) . maybeRight . termFromText
+tidFromText = fmap TermKey . maybeRight . termFromText
 
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
 
 nameWidget :: Text -> Text -> Widget
-nameWidget displayName surname
-  | null surname = toWidget displayName
+nameWidget displayName surname = toWidget $ nameHtml displayName surname
+
+nameHtml :: Text -> Text -> Html
+nameHtml displayName surname
+  | null surname = toHtml displayName
   | otherwise = case reverse $ T.splitOn surname displayName of
-      [_notContained] -> [whamlet|$newline never
+      [_notContained] -> [shamlet|$newline never
                             #{displayName} (
                             <b .surname>#{surname}
                             )|]
       (suffix:prefixes) ->
         let prefix = T.intercalate surname $ reverse prefixes
-        in [whamlet|$newline never
+        in [shamlet|$newline never
               #{prefix}
               <b .surname>#{surname}
               #{suffix}
@@ -73,3 +70,7 @@ warnTermDays tid times = do
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
 
+visibleWidget :: Bool -> Widget
+-- ^ @visibleWidget False@ is an icon that denotes that something™ is not visible
+visibleWidget True = mempty
+visibleWidget False = [whamlet|<i .fas .fa-eye-slash>|]

src/Handler/Utils/Course.hs

@@ -0,0 +1,27 @@
+module Handler.Utils.Course where
+
+import Import
+import Handler.Utils.Delete
+
+import qualified Database.Esqueleto as E
+  
+
+courseDeleteRoute :: Set CourseId -> DeleteRoute Course
+courseDeleteRoute drRecords = DeleteRoute
+  { drRecords
+  , drGetInfo = \(course `E.InnerJoin` school) -> do
+      E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+      E.orderBy [E.asc $ course E.^. CourseName]
+      return (course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+  , drUnjoin = \(course `E.InnerJoin` _) -> course
+  , drRenderRecord = \(E.Value cName, _, E.Value sName, E.Value tid') ->
+      return [whamlet|
+        #{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName})
+      |]
+  , drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') -> 
+      return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
+  , drCaption = SomeMessage MsgCourseDeleteQuestion
+  , drSuccessMessage = SomeMessage MsgCourseDeleted
+  , drAbort = error "drAbort undefined"
+  , drSuccess = error "drSuccess undefined"
+  }

src/Handler/Utils/DateTime.hs

@@ -1,31 +1,28 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , OverloadedStrings
-           , RecordWildCards
-           , TypeFamilies
-  #-}
-
 module Handler.Utils.DateTime
   ( utcToLocalTime
   , localTimeToUTC, TZ.LocalToUTCResult(..)
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
-  , addOneWeek
+  , formatTimeMail
+  , addOneWeek, addWeeks
+  , weekDiff, weeksToAdd
+  , setYear
   ) where
 
 import Import
 
-import Data.Time.Zones hiding (localTimeToUTCFull)
+import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
 import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
-import Data.Time.Clock (addUTCTime,nominalDay)
+-- import Data.Time.Clock (addUTCTime,nominalDay)
 import qualified Data.Time.Format as Time
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -42,7 +39,7 @@ instance HasLocalTime Day where
   toLocalTime d = LocalTime d midnight
 
 instance HasLocalTime UTCTime where
-  toLocalTime t = utcToLocalTime t
+  toLocalTime = utcToLocalTime
 
 formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
 formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
@@ -58,6 +55,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm
 formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
 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 = getTimeLocale' <$> languages
 
@@ -81,7 +81,7 @@ getDateTimeFormat sel = do
 
 validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
 -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
-validDateTimeFormats _ SelFormatDateTime = Set.fromList $
+validDateTimeFormats _ SelFormatDateTime = Set.fromList
   [ DateTimeFormat "%a %d %b %Y %R"
   , DateTimeFormat "%a %b %d %Y %R"
   , DateTimeFormat "%A, %d %B %Y %R"
@@ -98,7 +98,7 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $
   , DateTimeFormat "%Y-%m-%d %T"
   , DateTimeFormat "%Y-%m-%dT%T"
   ]
-validDateTimeFormats _ SelFormatDate = Set.fromList $
+validDateTimeFormats _ SelFormatDate = Set.fromList
   [ DateTimeFormat "%a %d %b %Y"
   , DateTimeFormat "%a %b %d %Y"
   , DateTimeFormat "%A, %d %B %Y"
@@ -128,14 +128,42 @@ dateTimeFormatOptions sel = do
 
   let
     toOption fmt@DateTimeFormat{..} = do
-      dateTime <- formatTime' unDateTimeFormat now 
-      return $ (dateTime, fmt)
-  
-  optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel 
+      dateTime <- formatTime' unDateTimeFormat now
+      return (dateTime, fmt)
+
+  optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
 
 
 addOneWeek :: UTCTime -> UTCTime
-addOneWeek = addUTCTime (7 * nominalDay)
+addOneWeek = addWeeks 1
 
--- addOneTerm? -> Move Handler.Utils.DateTime
+addWeeks :: Integer -> UTCTime -> UTCTime
+addWeeks n utct = utct { utctDay = newDay }
+  where
+    oldDay = utctDay utct
+    -- newDay = addGregorianDurationRollOver $ stimes n calendarWeek -- only available in newer version 1.9 of Data.Time.Calendar
+    newDay = addDays (7*n) oldDay
 
+weekDiff :: UTCTime -> UTCTime -> Integer
+-- ^ Difference between times, rounded down to weeks
+weekDiff old new = dayDiff `div` 7
+  where
+    dayOld  = utctDay old
+    dayNew  = utctDay new
+    dayDiff = diffDays dayNew dayOld
+
+weeksToAdd :: UTCTime -> UTCTime -> Integer
+-- ^ Number of weeks needed to add so that first
+--   time occurs later than second time
+--   (loop avoids off-by-one error with weekDiff corner cases)
+weeksToAdd old new = loop 0 old
+  where
+    loop n t
+      | t > new   = n
+      | otherwise = loop (succ n) (addOneWeek t)
+
+
+setYear :: Integer -> Day -> Day
+setYear year date = fromGregorian year month day
+  where
+    (_,month,day) = toGregorian date

src/Handler/Utils/Delete.hs

@@ -0,0 +1,102 @@
+module Handler.Utils.Delete
+  ( DeleteRoute(..)
+  , deleteR
+  , postDeleteR, getDeleteR
+  ) where
+
+import Import
+import Handler.Utils.Form
+
+import Utils.Lens
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+import qualified Data.CaseInsensitive as CI
+
+import Data.Char (isAlphaNum)
+
+import qualified Database.Esqueleto as E
+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
+  { drRecords :: Set (Key record)
+  , drUnjoin :: tables -> E.SqlExpr (Entity record)
+  , drGetInfo :: tables -> E.SqlQuery infoExpr
+  , drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+  , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
+  , drCaption
+  , drSuccessMessage :: SomeMessage UniWorX
+  , drAbort
+  , drSuccess :: SomeRoute UniWorX
+  }
+
+confirmForm :: ( MonadHandler m, HandlerSite m ~ UniWorX )
+           => Text -- ^ Confirmation string
+           -> AForm m Bool
+confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelete) -> if
+  | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
+    -> return $ pure True
+  | otherwise
+    -> formFailure [MsgDeleteConfirmationWrong]
+  where
+    aform = (,)
+        <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
+        <*> disambiguateButtons (combinedButtonFieldF "")
+    confirmField
+      | multiple  = convertField unTextarea Textarea textareaField
+      | otherwise = textField
+    multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
+
+confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
+confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
+  where
+    addDeleteTargets :: Form a -> Form a
+    addDeleteTargets form csrf = do
+      (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
+      over _2 (mappend $ fvInput fvTargets) <$> form csrf
+
+
+postDeleteR :: ( DeleteCascade record SqlBackend )
+            => (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
+            -> Handler ()
+-- | Perform deletion
+postDeleteR mkRoute = do
+  drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
+
+  void . for drResult $ \DeleteRoute{..} -> do
+    confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
+
+    ((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
+
+    formResult confirmRes $ \case
+      True -> do
+        runDB $ do
+          forM_ drRecords deleteCascade
+          addMessageI Success drSuccessMessage
+        redirect drSuccess
+      False ->
+        redirect drAbort
+
+
+getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
+getDeleteR DeleteRoute{..} = do
+  targets <- runDB $ mapM (\i -> (,) <$> drRenderRecord i <*> drRecordConfirmString i) <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
+
+  let confirmString = Text.unlines $ view _2 <$> targets
+
+  (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
+
+  Just targetRoute <- getCurrentRoute
+  
+  sendResponse =<<
+    defaultLayout $(widgetFile "widgets/delete-confirmation")
+
+
+
+deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
+deleteR dr = do
+  postDeleteR $ \drRecords -> dr {drRecords}
+  getDeleteR dr

src/Handler/Utils/Form.hs

@@ -1,108 +1,103 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE LambdaCase #-}
-
 module Handler.Utils.Form
   ( module Handler.Utils.Form
   , module Utils.Form
+  , MonadWriter(..)
   ) where
 
 import Utils.Form
 
 import Handler.Utils.Form.Types
-import Handler.Utils.Templates
 
 import Handler.Utils.DateTime
-import qualified Data.Time as Time
 
-import Import
+import Import hiding (cons)
 import qualified Data.Char as Char
-import Data.String (IsString(..))
 
-import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
-import qualified Data.Foldable as Foldable
-
 -- import Yesod.Core
 import qualified Data.Text as T
 -- import Yesod.Form.Types
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3
 
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
-
 import Handler.Utils.Zip
 import qualified Data.Conduit.List as C
 
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 
-import Data.Map (Map)
+import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
+import Control.Monad.Trans.Writer (execWriterT, WriterT)
+import Control.Monad.Except (runExceptT)
 import Control.Monad.Writer.Class
 
 import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
 
+import Utils.Lens
+
+import Data.Aeson (eitherDecodeStrict')
+import Data.Aeson.Text (encodeToLazyText)
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
 
-data BtnDelete = BtnDelete | BtnAbort
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+data ButtonDelete = BtnDelete
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonDelete
+instance Finite ButtonDelete
 
-instance PathPiece BtnDelete where    -- for displaying the button only, not really for paths
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1
 
-instance Button UniWorX BtnDelete where
-  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
-  label BtnAbort  = [whamlet|_{MsgBtnAbort}|]
+embedRenderMessage ''UniWorX ''ButtonDelete id
+instance Button UniWorX ButtonDelete where
+  btnClasses BtnDelete = [BCIsButton, BCDanger]
 
-  cssClass BtnDelete = BCDanger
-  cssClass BtnAbort  = BCDefault
+data ButtonRegister = BtnRegister | BtnDeregister
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonRegister
+instance Finite ButtonRegister
 
-data RegisterButton = BtnRegister  | BtnDeregister
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1
 
-instance PathPiece RegisterButton where
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+embedRenderMessage ''UniWorX ''ButtonRegister id
+instance Button UniWorX ButtonRegister where
+  btnClasses BtnRegister   = [BCIsButton, BCPrimary]
+  btnClasses BtnDeregister = [BCIsButton, BCDanger]
 
-instance Button UniWorX RegisterButton where
-  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
-  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
+data ButtonHijack = BtnHijack
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonHijack
+instance Finite ButtonHijack
 
-  cssClass BtnRegister   = BCPrimary
-  cssClass BtnDeregister = BCDanger
+nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1
 
-data AdminHijackUserButton = BtnHijack
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+embedRenderMessage ''UniWorX ''ButtonHijack id
+instance Button UniWorX ButtonHijack where
+  btnClasses BtnHijack = [BCIsButton, BCDefault]
 
-instance PathPiece AdminHijackUserButton where
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 
-instance Button UniWorX AdminHijackUserButton where
-  label BtnHijack = [whamlet|_{MsgBtnHijack}|]
+instance Universe ButtonSubmitDelete
+instance Finite ButtonSubmitDelete
 
-  cssClass BtnHijack = BCDefault
+embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
+instance Button UniWorX ButtonSubmitDelete where
+  btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
+  btnClasses BtnDelete' = [BCIsButton, BCDanger]
+
+  btnValidate _ BtnSubmit' = True
+  btnValidate _ BtnDelete' = False
+
+nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
 
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
@@ -112,8 +107,14 @@ instance Button UniWorX AdminHijackUserButton where
 -- instance PathPiece LinkButton where
 --     LinkButton route = ???
 
-linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
-linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
+linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
+linkButton lbl cls url = do
+  url' <- toTextUrl url
+  [whamlet|
+    $newline never
+    <a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
+      ^{lbl}
+  |]
 --   [whamlet|
 --     <form method=post action=@{url}>
 --       <input type="hidden" name="_formid" value="identify-linkButton">
@@ -122,31 +123,16 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
 
--- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
-buttonForm :: (Button UniWorX a, Show a) => Form a
+-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+buttonForm :: (Button UniWorX a, Finite a) => Form a
 buttonForm csrf = do
-    buttonIdent <- newFormIdent
-    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
-    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
-    let widget = do
-          [whamlet|
-            #{csrf}
-            $forall bView <- btnViews
-              ^{fvInput bView}
-          |]
-    return (accResult results,widget)
-  where
-    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
-    accResult = Foldable.foldr accResult' FormMissing
-
-    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-    -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
-    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
-    accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess
-    accResult' (FormSuccess Nothing) x = x
-    accResult' FormMissing _ = FormMissing
-    accResult' (FormFailure errs) _ = FormFailure errs
+   (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
+   return (res, [whamlet|
+       $newline never
+       #{csrf}
+       $forall bView <- fViews
+         ^{fvInput bView}
+     |])
 
 
 
@@ -156,20 +142,25 @@ buttonForm csrf = do
 
 -- ciField moved to Utils.Form
 
+routeField :: ( Monad m
+              , HandlerSite m ~ UniWorX
+              ) => Field m (Route UniWorX)
+routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
+
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField
 
 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
-natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intField
+natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") intField
 
 natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
 natIntField = natField
 
 posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
-posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") $ intField
+posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") intField
 
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
-minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
+minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
 
 pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
 pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
@@ -184,6 +175,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
       sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
       return . fromRational $ round (sci * 100) % 100
 
+pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions
+pointsFieldMax Nothing = pointsField
+pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
 
 termsActiveField :: Field Handler TermId
 termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
@@ -218,11 +212,19 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
 uploadModeField :: Field Handler UploadMode
-uploadModeField = selectFieldList
-  [ (MsgUploadModeNone    , NoUpload      )
-  , (MsgUploadModeNoUnpack, Upload   False)
-  , (MsgUploadModeUnpack  , Upload   True )
-  ]
+uploadModeField = selectField optionsFinite
+
+submissionModeField :: Field Handler SheetSubmissionMode
+submissionModeField = selectField optionsFinite
+
+pseudonymWordField :: Field Handler PseudonymWord
+pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
+  where
+    doCheck (CI.mk -> w)
+      | Just w' <- find (== w) pseudonymWordlist
+      = return $ Right w'
+      | otherwise
+      = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
 zipFileField :: Bool -- ^ Unpack zips?
              -> Field Handler (Source Handler File)
@@ -233,7 +235,7 @@ zipFileField doUnpack = Field{..}
       | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
       | null files   = return $ Right Nothing
       | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
-    fieldView fieldId fieldName attrs _ req = do
+    fieldView fieldId fieldName attrs _ req =
       [whamlet|
         $newline never
         <input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
@@ -243,29 +245,26 @@ multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either
 multiFileField permittedFiles' = Field{..}
   where
     fieldEnctype = Multipart
-    fieldParse vals files
-      | null files
-      , null vals = return $ Right Nothing
-      | otherwise = return . Right . Just $ do
-          pVals <- lift permittedFiles'
-          let
-            decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
-            decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
-          yieldMany vals
-            .| C.filter (/= unpackZips)
-            .| C.map fromPathPiece .| C.catMaybes
-            .| C.mapMaybeM decrypt'
-            .| C.filter (`elem` pVals)
-            .| C.map Left
-          let
-            handleFile :: FileInfo -> Source Handler File
-            handleFile
-              | doUnpack  = sourceFiles
-              | otherwise = yieldM . acceptFile
-          mapM_ handleFile files .| C.map Right
+    fieldParse vals files = return . Right . Just $ do
+      pVals <- lift permittedFiles'
+      let
+        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
+      yieldMany vals
+        .| C.filter (/= unpackZips)
+        .| C.map fromPathPiece .| C.catMaybes
+        .| C.mapMaybeM decrypt'
+        .| C.filter (`elem` pVals)
+        .| C.map Left
+      let
+        handleFile :: FileInfo -> Source Handler File
+        handleFile
+          | doUnpack  = sourceFiles
+          | otherwise = yieldM . acceptFile
+      mapM_ handleFile files .| C.map Right
       where
         doUnpack = unpackZips `elem` vals
-    fieldView fieldId fieldName attrs val req = do
+    fieldView fieldId fieldName _attrs val req = do
       pVals <- handlerToWidget permittedFiles'
       sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
       let
@@ -275,7 +274,7 @@ multiFileField permittedFiles' = Field{..}
           let fuiChecked
                 | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
                 | otherwise = True
-          return FileUploadInfo{..}     
+          return FileUploadInfo{..}
       fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
           E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
           E.orderBy [E.asc $ file E.^. FileTitle]
@@ -288,23 +287,108 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
-sheetTypeAFormReq d Nothing =
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
-sheetTypeAFormReq d (Just (Normal p)) =
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
-sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded
 
+data SheetGrading' = Points' | PassPoints' | PassBinary'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetGrading'
+instance Finite SheetGrading'
+
+nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
+embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
+
+
+data SheetType' = NotGraded' | Normal' | Bonus' | Informational'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetType'
+instance Finite SheetType'
+
+nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
+embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
+
+
+data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetGroup'
+instance Finite SheetGroup'
+
+nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
+embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
+
+sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
+sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+  where
+    selOptions = Map.fromList
+      [ ( Points',     Points     <$> maxPointsReq )
+      , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
+      , ( PassBinary', pure PassBinary)
+      ]
+    classify' :: SheetGrading -> SheetGrading'
+    classify' = \case
+      Points     {} -> Points'
+      PassPoints {} -> PassPoints'
+      PassBinary {} -> PassBinary'
+
+    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints)     (template >>= preview _maxPoints)
+    passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
+
+
+sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+  where
+    selOptions = Map.fromList
+      [ ( Normal', Normal <$> gradingReq )
+      , ( Bonus' , Bonus  <$> gradingReq )
+      , ( Informational', Informational <$> gradingReq  )
+      , ( NotGraded', pure NotGraded )
+      ]
+    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
+        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
+
+    classify' :: SheetType -> SheetType'
+    classify' = \case
+      Bonus  {} -> Bonus'
+      Normal {} -> Normal'
+      Informational {} -> Informational'
+      NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
-sheetGroupAFormReq d _other = -- TODO
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
+sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
+  let
+    selOptions = Map.fromList
+      [ ( Arbitrary', Arbitrary
+          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
+        )
+      , ( RegisteredGroups', pure RegisteredGroups )
+      , ( NoGroups', pure NoGroups )
+      ]
+  (res, selView) <- multiAction selOptions (classify' <$> template)
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+  where
+    classify' :: SheetGroup -> SheetGroup'
+    classify' = \case
+      Arbitrary _ -> Arbitrary'
+      RegisteredGroups -> RegisteredGroups'
+      NoGroups -> NoGroups'
+
 
 {-
 dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
@@ -329,7 +413,7 @@ utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
 -- Browser returns LocalTime
 utcTimeField = Field
-    { fieldParse = parseHelperGen $ readTime
+    { fieldParse = parseHelperGen readTime
     , fieldView = \theId name attrs val isReq -> do
         val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
         [whamlet|
@@ -342,15 +426,84 @@ utcTimeField = Field
     fieldTimeFormat :: String
     --fieldTimeFormat = "%e.%m.%y %k:%M"
     fieldTimeFormat = "%Y-%m-%dT%H:%M"
-    
-    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 
+
+    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
     readTime :: Text -> Either UniWorXMessage UTCTime
     readTime t =
       case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
-        (Just (LTUUnique time _))     -> Right time
-        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
-        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
-        Nothing -> Left MsgInvalidDateTimeFormat
+        Just LTUUnique{_ltuResult} -> Right _ltuResult
+        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
+        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
+        Nothing                    -> Left MsgInvalidDateTimeFormat
+
+langField :: Bool -- ^ Only allow values from `appLanguages`
+          -> Field (HandlerT UniWorX IO) Lang
+langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
+langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
+
+jsonField :: ( ToJSON a, FromJSON a
+             , MonadHandler m
+             , RenderMessage (HandlerSite m) UniWorXMessage
+             , RenderMessage (HandlerSite m) FormMessage
+             )
+          => Bool {-^ Hidden? -}
+          -> Field m a
+jsonField hide = Field{..}
+  where
+    inputType :: Text
+    inputType
+      | hide      = "hidden"
+      | otherwise = "text"
+    fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val isReq = liftWidgetT [whamlet|
+      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
+    |]
+    fieldEnctype = UrlEncoded
+
+secretJsonField :: ( ToJSON a, FromJSON a
+                   , MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   )
+                => Field m a
+secretJsonField = Field{..}
+  where
+    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val _isReq = do
+      val' <- traverse (encodedSecretBox SecretBoxShort) val
+      [whamlet|
+        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
+      |]
+    fieldEnctype = UrlEncoded
+
+
+funcForm :: forall k v m.
+            ( Finite k, Ord k
+            , MonadHandler m
+            , HandlerSite m ~ UniWorX
+            )
+         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
+  where
+    funcForm' :: AForm m (k -> v)
+    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
+    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
+    funcFieldView (res, fvInput) = do
+      mr <- getMessageRender
+      let fvLabel = toHtml $ mr fsLabel
+          fvTooltip = fmap (toHtml . mr) fsTooltip
+          fvRequired = isRequired
+          fvErrors
+            | FormFailure (err:_) <- res = Just $ toHtml err
+            | otherwise = Nothing
+      fvId <- maybe newIdent return fsId
+      return (res, pure FieldView{..})
+    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
+
+
 
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
@@ -359,6 +512,10 @@ fsm = bfs -- TODO: get rid of Bootstrap
 fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
 
+fsUniq :: (Text -> Text) -> Text -> FieldSettings site
+fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
+
+
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site
                           , PersistQueryRead backend
@@ -375,24 +532,12 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
   mr <- getMessageRender
   pairs <- runDB $ selectList filts ords
   cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
-  return $ map (\(cId, e@(Entity key value)) -> Option
+  return $ map (\(cId, e@(Entity _key value)) -> Option
                  { optionDisplay = mr (toDisplay value)
                  , optionInternalValue = e
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
-optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
-              => (a -> msg) -> m (OptionList a)
-optionsFinite toMsg = do
-  mr <- getMessageRender
-  let
-    mkOption a = Option
-      { optionDisplay       = mr $ toMsg a
-      , optionInternalValue = a
-      , optionExternalValue = toPathPiece a
-      }
-  return . mkOptionList $ mkOption <$> universeF
-
 mforced :: (site ~ HandlerSite m, MonadHandler m)
         => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
 mforced Field{..} FieldSettings{..} val = do
@@ -416,15 +561,72 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ second pure <$> mforced field settings val
 
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+-- ^ Pseudo required
+apreq f fs mx = formToAForm $ do
+  mr <- getMessageRender
+  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
+
+wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpreq f fs mx = mFormToWForm $ do
+  mr <- getMessageRender
+  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
+
 multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            => Map action (AForm (HandlerT UniWorX IO) a)
+            -> Maybe action
             -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-multiAction acts = do
+multiAction acts defAction = do
   mr <- getMessageRender
   let
     options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
-  results <- sequence acts
-  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
+  let mToWidget (_, []) = return Nothing
+      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
+  widgets <- mapM mToWidget results
+  let actionWidgets = Map.foldrWithKey accWidget [] widgets
+      accWidget _act Nothing = id
+      accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
       actionResults = Map.map fst results
   return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
+
+multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+            => FieldSettings UniWorX
+            -> Map action (AForm (HandlerT UniWorX IO) a)
+            -> Maybe action
+            -> AForm (HandlerT UniWorX IO) a
+multiActionA FieldSettings{..} acts defAction = formToAForm $ do
+  (res, selView) <- multiAction acts defAction
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
+formResultModal res finalDest handler = maybeT_ $ do
+  messages <- case res of
+    FormMissing -> mzero
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
+    FormSuccess val -> lift . execWriterT $ handler val
+
+  isModal <- hasCustomHeader HeaderIsModal
+  if
+    | isModal   -> sendResponse $ toJSON messages
+    | otherwise -> do
+        forM_ messages $ \Message{..} -> addMessage messageClass messageContent
+        redirect finalDest

src/Handler/Utils/Form/Types.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Handler.Utils.Form.Types where
 
 import Import

src/Handler/Utils/Mail.hs

@@ -0,0 +1,72 @@
+module Handler.Utils.Mail
+  ( addRecipientsDB
+  , userMailT
+  , addFileDB
+  ) where
+
+import Import
+
+import Utils.Lens hiding (snoc)
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.ByteString.Lazy as LBS
+
+import qualified Data.Conduit.List as C
+
+import System.FilePath (takeBaseName)
+import Network.Mime (defaultMimeLookup)
+
+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
+  where
+    addRecipient (Entity _ User{userEmail, userDisplayName}) = do
+      let addr = Address (Just userDisplayName) $ CI.original userEmail
+      _mailTo %= flip snoc addr
+
+userMailT :: ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             , MonadBaseControl IO m
+             , MonadLogger m
+             ) => UserId -> MailT m a -> m a
+userMailT uid mAct = do
+  User
+    { userEmail
+    , userDisplayName
+    , userMailLanguages
+    , userDateTimeFormat
+    , userDateFormat
+    , userTimeFormat
+    } <- liftHandlerT . runDB $ getJust uid
+  let
+    addr = Address (Just userDisplayName) $ CI.original userEmail
+    ctx = MailContext
+      { mcLanguages = userMailLanguages
+      , mcDateTimeFormat = \case
+          SelFormatDateTime -> userDateTimeFormat
+          SelFormatDate -> userDateFormat
+          SelFormatTime -> userTimeFormat
+      }
+  mailT ctx $ do
+    _mailTo .= pure addr
+    mAct
+
+addFileDB :: ( MonadMail m
+             , MonadHandler m
+             , HandlerSite m ~ UniWorX
+             ) => FileId -> m MailObjectId
+addFileDB fId = do
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
+  addPart $ do
+    _partType .= decodeUtf8 (defaultMimeLookup fileName)
+    _partEncoding .= Base64
+    _partFilename .= Just fileName
+    _partContent .= LBS.fromStrict fileContent
+    setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

src/Handler/Utils/Rating.hs

@@ -1,19 +1,8 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
-
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Handler.Utils.Rating
   ( Rating(..), Rating'(..)
+  , validateRating
   , getRating
   , formatRating
   , ratingFile
@@ -25,14 +14,12 @@ module Handler.Utils.Rating
   , extractRatings
   ) where
 
-import Import hiding ((</>))
-
+import Import
 
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
 import Control.Monad.Trans.Maybe
 
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Text.Encoding.Error (UnicodeException(..))
@@ -47,9 +34,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
 
 import Text.Read (readEither)
 
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
 import System.FilePath
 import qualified System.FilePath.Cryptographic as FilePath (decrypt)
 
@@ -57,6 +41,8 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
+import Utils.Lens
+
 
 instance HasResolution prec => Pretty (Fixed prec) where
   pretty = pretty . show
@@ -65,29 +51,25 @@ instance Pretty x => Pretty (CI x) where
   pretty = pretty . CI.original
 
 
-data Rating = Rating
-  { ratingCourseName :: CourseName
-  , ratingSheetName :: SheetName
-  , ratingCorrectorName :: Maybe Text
-  , ratingSheetType :: SheetType
-  , ratingValues :: Rating'
-  } deriving (Read, Show, Eq, Generic, Typeable)
+instance Pretty SheetGrading where
+  pretty Points{..}     = pretty ( show maxPoints <> " Punkte" :: String)
+  pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
+  pretty PassBinary     = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: String )
 
-data Rating' = Rating'
-  { ratingPoints :: Maybe Points
-  , ratingComment :: Maybe Text
-  , ratingTime :: Maybe UTCTime
-  } deriving (Read, Show, Eq, Generic, Typeable)
-
-data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
-                     | RatingMissingSeparator -- ^ Could not split rating header from comments
-                     | RatingMultiple -- ^ Encountered multiple point values in rating
-                     | RatingInvalid String -- ^ Failed to parse rating point value
-                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
-  deriving (Show, Eq, Generic, Typeable)
-
-instance Exception RatingException
 
+validateRating :: SheetType -> Rating' -> [RatingException]
+validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
+  | rp < 0
+    = [RatingNegative]
+  | NotGraded <- ratingSheetType
+    = [RatingNotExpected]
+  | (Just maxPoints ) <- ratingSheetType ^?  _grading . _maxPoints
+  , rp > maxPoints
+    = [RatingExceedsMax]
+  | (Just PassBinary) <- ratingSheetType ^? _grading
+  , not (rp == 0 || rp == 1)
+    = [RatingBinaryExpected]
+validateRating _ _ = []
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
 getRating submissionId = runMaybeT $ do
@@ -116,7 +98,7 @@ getRating submissionId = runMaybeT $ do
     , E.unValue -> ratingComment
     , E.unValue -> ratingTime
     ) ] <- lift query
-  
+
   return Rating{ ratingValues = Rating'{..}, .. }
 
 formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
@@ -131,7 +113,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
       [ Just $ "Veranstaltung:" <+> pretty ratingCourseName
       , Just $ "Blatt:" <+> pretty ratingSheetName
       , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
-      , Just $ "Bewertung:" <+> pretty (display ratingSheetType)
+      , ("Bewertung:" <+>) . pretty <$> (ratingSheetType ^? _grading)
       ]
     , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
     , "============================================="
@@ -142,10 +124,10 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
   in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
 
 ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
-ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
+ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
   fileModified <- maybe (liftIO getCurrentTime) return ratingTime
   let
-    fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
+    fileTitle = "bewertung_" <> Text.unpack (toPathPiece cID) <.> "txt"
     fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
   return File{..}
 
@@ -153,10 +135,10 @@ parseRating :: MonadThrow m => File -> m Rating'
 parseRating File{ fileContent = Just input, .. } = do
   inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
   let
-    (headerLines', commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
-    (reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
+    (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
+    (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
     ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
-    sep = "Beginn der Kommentare"
+    commentSep = "Beginn der Kommentare"
     sep' = Text.pack $ replicate 40 '='
     rating = "Bewertung:"
   comment' <- case commentLines of
@@ -166,7 +148,7 @@ parseRating File{ fileContent = Just input, .. } = do
     ratingComment
       | Text.null comment' = Nothing
       | otherwise = Just comment'
-  ratingLine' <- case ratingLines of
+  ratingLine' <- case ratingLines' of
     [l] -> return l
     _ -> throw RatingMultiple
   let

src/Handler/Utils/Sheet.hs

@@ -1,23 +1,12 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Handler.Utils.Sheet where
 
 import Import
+import Handler.Utils.Delete
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
 
-
-
 fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
                   , E.SqlSelect b a
                   , Typeable a, MonadHandler m, IsPersistBackend backend
@@ -51,3 +40,31 @@ fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ss
 
 fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
 fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
+
+
+sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
+sheetDeleteRoute drRecords = DeleteRoute
+  { drRecords
+  , drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
+      E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+      let submissions = E.sub_select . E.from $ \submission -> do
+            E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+            return E.countRows
+      E.orderBy [E.asc $ sheet E.^. SheetName]
+      return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+  , drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
+  , drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
+      return [whamlet|
+        $newline never
+        #{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
+        $if submissions /= 0
+          &nbsp;<i>_{SomeMessage $ MsgSheetDelHasSubmissions submissions}
+      |]
+  , drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
+      return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
+  , drCaption = SomeMessage MsgSheetDeleteQuestion
+  , drSuccessMessage = SomeMessage MsgSheetDeleted
+  , drAbort = error "drAbort undefined"
+  , drSuccess = error "drSuccess undefined"
+  }

src/Handler/Utils/SheetType.hs

@@ -0,0 +1,36 @@
+module Handler.Utils.SheetType
+  (
+    gradeSummaryWidget
+  ) where
+
+import Import
+import Data.Monoid (Sum(..))
+import Utils.Lens
+
+addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
+addBonusToPoints sts =
+    sts & _normalSummary . _achievedPasses %~ (min passmax . (passbonus +))
+        & _normalSummary . _achievedPoints %~ (min ptsmax  . (ptsbonus  +))
+  where
+    passmax   = sts ^. _normalSummary . _numMarkedPasses
+    passbonus = sts ^. _bonusSummary  . _achievedPasses
+    ptsmax    = sts ^. _normalSummary . _sumMarkedPoints
+    ptsbonus  = sts ^. _bonusSummary  . _achievedPoints
+
+gradeSummaryWidget ::  RenderMessage UniWorX msg => (Integer -> msg) -> SheetTypeSummary -> Widget
+gradeSummaryWidget title sts =
+  let SheetTypeSummary{..} = addBonusToPoints sts
+      sumSummaries    = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
+      hasPasses       = positiveSum $ numSheetsPasses sumSummaries
+      hasMarkedPasses = positiveSum $ numMarkedPasses sumSummaries
+      hasPoints       = positiveSum $ numSheetsPoints sumSummaries
+      hasMarkedPoints = positiveSum $ numMarkedPoints sumSummaries
+      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
+                  | (sumHeader,summary) <-
+                    [ (MsgSheetTypeNormal'        ,normalSummary)
+                    , (MsgSheetTypeBonus'         ,bonusSummary)
+                    , (MsgSheetTypeInformational' ,informationalSummary)
+                  ] ]
+  in if 0 == numSheets sumSummaries
+        then mempty
+        else $(widgetFile "widgets/gradingSummary")

src/Handler/Utils/StudyFeatures.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-  #-}
-
 module Handler.Utils.StudyFeatures
   ( parseStudyFeatures
   ) where
@@ -41,8 +37,8 @@ pKey :: Parser Int
 pKey = decimal
 
 pType :: Parser StudyFieldType
-pType = FieldPrimary   <$ (try $ string "HF")
-    <|> FieldSecondary <$ (try $ string "NF")
+pType = FieldPrimary   <$ try (string "HF")
+    <|> FieldSecondary <$ try (string "NF")
 
 decimal :: Parser Int
 decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'

src/Handler/Utils/Submission.hs

@@ -1,35 +1,21 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
 module Handler.Utils.Submission
   ( AssignSubmissionException(..)
   , assignSubmissions
   , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
   , submissionFileSource, submissionFileQuery
-  , submissionMultiArchive 
+  , submissionMultiArchive
   , SubmissionSinkException(..)
+  , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
   , sinkSubmission, sinkMultiSubmission
   , submissionMatchesSheet
+  , submissionDeleteRoute
   ) where
 
-import Import hiding ((.=), joinPath)
+import Import hiding (joinPath)
+import Jobs.Queue
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
-import Control.Lens
-import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
@@ -38,32 +24,27 @@ import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
-import Data.Maybe
+import Data.Maybe ()
 
 import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map, (!?))
+import Data.Map (Map)
 import qualified Data.Map as Map
 
 import qualified Data.Text as Text
 import Data.Ratio
 
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-
 import Data.Monoid (Monoid, Any(..), Sum(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
-import Handler.Utils.Rating hiding (extractRatings)
+import Handler.Utils
 import qualified Handler.Utils.Rating as Rating (extractRatings)
-import Handler.Utils.Zip
-import Handler.Utils.Sheet
 import Handler.Utils.Submission.TH
+import Handler.Utils.Delete
 
 import qualified Database.Esqueleto as E
 
-import Data.Conduit
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
 
@@ -83,14 +64,14 @@ instance Exception AssignSubmissionException
 -- | Assigns all submissions according to sheet corrector loads
 assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
                   -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-                  -> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
-                                     , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
-                                     )
+                  -> YesodDB UniWorX ( Set SubmissionId
+                                     , Set SubmissionId
+                                     ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
 assignSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
     let
-      byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
+      -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
       corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
       corrsProp  = filter hasPositiveLoad correctors
       countsToLoad' :: UserId -> Bool
@@ -132,7 +113,7 @@ assignSubmissions sid restriction = do
     let
       prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
       prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
-        (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
+        (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
         guard $ maybe True (not isByTutorial ||) byTutorial
         let proportion
               | CorrectorExcused <- sheetCorrectorState = 0
@@ -149,7 +130,9 @@ assignSubmissions sid restriction = do
           props = getSum $ foldMap (Sum . fst) assignments
 
           toDeficit' (prop, assigned) = let
-              target = round $ fromInteger assigned' * (prop / props)
+              target
+                | props == 0 = 0
+                | otherwise  = round $ fromInteger assigned' * (prop / props)
             in target - assigned
 
     $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
@@ -162,9 +145,9 @@ assignSubmissions sid restriction = do
       wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ]
       detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit
       detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps
-    
+
     $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
-    
+
     queue <- liftIO . Rand.evalRandIO . execWriterT $ do
       tell $ map Just detQueue
       forever $
@@ -182,11 +165,11 @@ assignSubmissions sid restriction = do
 
       maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
       maximumDeficit = do
-        transposed <- uses _3 invertMap 
+        transposed <- uses _3 invertMap
         traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
 
     subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
-          
+
     subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do
       let
         restrictTuts
@@ -197,7 +180,7 @@ assignSubmissions sid restriction = do
         Just q' -> do
           $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)"
           assignSubmission False smid q'
-        Nothing 
+        Nothing
           | Set.null tuts -> do
               q <- preuse $ _2 . _head . _Just
               case q of
@@ -214,7 +197,7 @@ assignSubmissions sid restriction = do
     forM_ (Map.toList subTutor) $
         \(smid, tutid) -> update smid [ SubmissionRatingBy       =. Just tutid
                                       , SubmissionRatingAssigned =. Just now  ]
-        
+
     let assignedSubmissions   = Map.keysSet subTutor
         unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
     return (assignedSubmissions, unassigendSubmissions)
@@ -242,7 +225,7 @@ submissionMultiArchive (Set.toList -> ids) = do
   ratedSubmissions <- runDBRunner dbrunner $ do
     submissions <- selectList [ SubmissionId <-. ids ] []
     forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
-  
+
   (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
     let
       fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
@@ -251,7 +234,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 
         let
           directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
-              
+
           fileEntitySource = do
             submissionFileSource submissionID =$= Conduit.map entityVal
             yieldM (ratingFile cID rating)
@@ -269,7 +252,7 @@ submissionMultiArchive (Set.toList -> ids) = do
           }
 
         fileEntitySource =$= mapC withinDirectory
-          
+
     mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
 
 
@@ -279,6 +262,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any
+  , sinkSubmissionNotifyRating :: Any
   , sinkFilenames :: Set FilePath
   } deriving (Show, Eq, Generic, Typeable)
 
@@ -286,14 +270,6 @@ instance Monoid SubmissionSinkState where
   mempty = memptydefault
   mappend = mappenddefault
 
-data SubmissionSinkException = DuplicateFileTitle FilePath
-                             | DuplicateRating
-                             | RatingWithoutUpdate
-                             | ForeignRating CryptoFileNameSubmission
-  deriving (Typeable, Show)
-
-instance Exception SubmissionSinkException
-
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
 
@@ -324,16 +300,28 @@ extractRatingsMsg :: ( MonadHandler m
                      ) => Conduit File m SubmissionContent
 extractRatingsMsg = do
   ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
-  let ignored :: Set (Either CryptoFileNameSubmission FilePath)
-      ignored = Right `Set.map` ignored'
-  unless (null ignored) $ do
+  let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
+      ignoredFiles = Right `Set.map` ignored'
+  unless (null ignoredFiles) $ do
     mr <- (toHtml . ) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
+-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
+msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
+msgSubmissionErrors = flip catches
+    [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException)
+    , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
+    , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do
+        mr <- getMessageRender
+        addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx)
+        return Nothing
+    ] . fmap Just
+
+
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
-               -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
+               -> Sink SubmissionContent (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'.
@@ -359,20 +347,19 @@ sinkSubmission userId mExists isUpdate = do
       return sId
     Right sId -> return sId
 
-  sId <$ sinkSubmission' sId isUpdate
+  sId <$ sinkSubmission' sId
   where
-    tell = modify . mappend
+    tellSt = modify . mappend
 
     sinkSubmission' :: SubmissionId
-                    -> Bool -- ^ Is this a correction
-                    -> Sink SubmissionContent (YesodDB UniWorX) ()
-    sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
+                    -> Sink SubmissionContent (YesodJobDB UniWorX) ()
+    sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
 
         alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
         when alreadySeen . throwM $ DuplicateFileTitle fileTitle
-        tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }
+        tellSt $ mempty{ sinkFilenames = Set.singleton fileTitle  }
 
         otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
           E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@@ -394,7 +381,7 @@ sinkSubmission userId mExists isUpdate = do
               | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
               | otherwise                  = False
             undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
-  
+
         when anyChanges $ do
           touchSubmission
           when (not $ null collidingFiles) $
@@ -414,32 +401,36 @@ sinkSubmission userId mExists isUpdate = do
         when undoneDeletion $ do
           touchSubmission
           lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
-  
-      Right (submissionId', Rating'{..}) -> do
+
+      Right (submissionId', r'@Rating'{..}) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
         unless (submissionId' == submissionId) $ do
           cID <- encrypt submissionId'
           throwM $ ForeignRating cID
-        
+
         alreadySeen <- gets $ getAny . sinkSeenRating
         when alreadySeen $ throwM DuplicateRating
-        tell $ mempty{ sinkSeenRating = Any True }
+        tellSt $ mempty{ sinkSeenRating = Any True }
 
         unless isUpdate $ throwM RatingWithoutUpdate
 
         Submission{..} <- lift $ getJust submissionId
 
-        let anyChanges = or $ 
+        let anyChanges = or $
               [ submissionRatingPoints /= ratingPoints
               , submissionRatingComment /= ratingComment
               ]
         -- 'ratingTime' is ignored for consistency with 'File's:
-        -- 
+        --
         -- 'fileModified' is simply stored and never inspected while
         -- 'submissionChanged' is always set to @now@.
-
         when anyChanges $ do
+
+          Sheet{..} <- lift $ getJust submissionSheet
+          --TODO: should display errorMessages
+          mapM_ throwM $ validateRating sheetType r'
+
           touchSubmission
           lift $ update submissionId
             [ SubmissionRatingPoints =. ratingPoints
@@ -463,18 +454,21 @@ sinkSubmission userId mExists isUpdate = do
         -- The check whether the new version matches the underlying file is
         -- more lenient, considering only filename and -content.
 
-        touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
+        touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
         touchSubmission = do
           alreadyTouched <- gets $ getAny . sinkSubmissionTouched
           when (not alreadyTouched) $ do
             now <- liftIO getCurrentTime
-            lift $ case isUpdate of
-              False -> insert_ $ SubmissionEdit userId now submissionId
-              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
-                        -- TODO: Should submissionRatingAssigned change here if userId changes?
-            tell $ mempty{ sinkSubmissionTouched = Any True }
+            case isUpdate of
+              False -> lift . insert_ $ SubmissionEdit userId now submissionId
+              True  -> do
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
+                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                -- TODO: Should submissionRatingAssigned change here if userId changes?
+            tellSt $ mempty{ sinkSubmissionTouched = Any True }
 
-        finalize :: SubmissionSinkState -> YesodDB UniWorX ()
+        finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
             E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@@ -509,28 +503,25 @@ sinkSubmission userId mExists isUpdate = do
                   update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
-          when (isUpdate && not (getAny sinkSeenRating)) $
-            update submissionId
+          if
+            | isUpdate
+            , not $ getAny sinkSeenRating
+              -> update submissionId
               [ SubmissionRatingTime =. Nothing
               , SubmissionRatingPoints =. Nothing
               , SubmissionRatingBy =. Nothing
               , SubmissionRatingComment =. Nothing
               ]
+            | isUpdate
+            , getAny sinkSubmissionNotifyRating
+              -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
+            | otherwise -> return ()
 
-data SubmissionMultiSinkException
-  = SubmissionSinkException
-    { submissionSinkId :: CryptoFileNameSubmission
-    , submissionSinkFedFile :: Maybe FilePath
-    , submissionSinkException :: SubmissionSinkException
-    }                                   
-  deriving (Typeable, Show)
-
-instance Exception SubmissionMultiSinkException
 
 sinkMultiSubmission :: UserId
                     -> Bool {-^ Are these corrections -}
-                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
-               
+                    -> Sink SubmissionContent (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'.
 --
 -- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
@@ -543,8 +534,8 @@ sinkMultiSubmission userId isUpdate = do
          -> RWST
               ()
               _
-              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
-              (YesodDB UniWorX)
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
+              (YesodJobDB UniWorX)
               ()
     feed sId val = do
       mSink <- gets $ Map.lookup sId
@@ -553,7 +544,7 @@ sinkMultiSubmission userId isUpdate = do
         Nothing -> do
           lift $ do
             cID <- encrypt sId
-            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID 
+            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID
             Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
@@ -563,7 +554,7 @@ sinkMultiSubmission userId isUpdate = do
       case sink' of
         Left _ -> error "sinkSubmission returned prematurely"
         Right nSink -> modify $ Map.insert sId nSink
-  (sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case
+  (sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case
     v@(Right (sId, _)) -> do
       cID <- encrypt sId
       $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
@@ -590,20 +581,20 @@ sinkMultiSubmission userId isUpdate = do
           cID <- encrypt sId
           handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
             lift . feed sId $ Left f{ fileTitle = fileTitle' }
-  when (not $ null ignored) $ do
+  when (not $ null ignoredFiles) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
-  fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
+  lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
     cID <- encrypt sId
     handle (throwM . SubmissionSinkException cID Nothing) $
-      void $ closeResumableSink sink
+      closeResumableSink sink
   where
     handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
     handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
     handleHCError _ e = throwM e
     handleCryptoID :: CryptoIDError -> _ (Maybe a)
     handleCryptoID _ = return Nothing
-    
+
 
 submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
 submissionMatchesSheet tid ssh csh shn cid = do
@@ -612,3 +603,38 @@ submissionMatchesSheet tid ssh csh shn cid = do
   Submission{..} <- get404 sid
   when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
   return sid
+
+
+submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission
+submissionDeleteRoute drRecords = DeleteRoute
+  { drRecords
+  , drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission
+  , drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
+      E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+      E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
+      let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
+            E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
+            return . E.max_ $ submissionEdit E.^. SubmissionEditTime
+      E.orderBy [E.desc lastEdit]
+      return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+  , drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do
+      subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+      subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
+      return [whamlet|
+        $newline never
+        <ul .list--comma-separated .list--inline .list--iconless>
+          $forall (dName, sName) <- subNames
+            <li>^{nameWidget dName sName}
+        &nbsp;(_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
+      |]
+  , drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
+      subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+      subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
+      let subNames' = Text.intercalate ", " subNames
+      return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
+  , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
+  , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
+  , drAbort = error "drAbort undefined"
+  , drSuccess = error "drSuccess undefined"
+  }

src/Handler/Utils/Submission/TH.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , ViewPatterns
-           , OverloadedStrings
-           , StandaloneDeriving
-           , DeriveLift
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Submission.TH

src/Handler/Utils/Table.hs

@@ -1,13 +1,7 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeFamilies #-}
-
 module Handler.Utils.Table where
 -- General Utilities for Tables
 
-import Import hiding  ((<>))
--- import Data.Monoid ((<>))
+import Import
 import Data.Profunctor
 
 import Control.Monad.Except
@@ -64,11 +58,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
           extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
           case () of
             _ | extId `elem` extIds
-                -> Just <$> (lift $ fromExternal extId)
+                -> Just <$> lift (fromExternal extId)
               | otherwise
                 -> return Nothing
 
-        view _ name attributes val _ = do
+        view _ name attributes val _ =
           [whamlet|
             <label style="display: block">
               <input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>

src/Handler/Utils/Table/Cells.hs

@@ -1,16 +1,10 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.Utils.Table.Cells where
 
 import Import
 
 import Data.Monoid (Any(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Trans.Writer (WriterT)
 
 import Utils.Lens
 import Handler.Utils
@@ -21,8 +15,17 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
 --------------------
 -- Special cells
 
+tellCell :: (Monoid a, 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 = flip tellCell
+
 indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
-indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
+indicatorCell = writerCell . tell $ Any True
+
+writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
+writerCell act = mempty & cellContents %~ (<* act)
 
 -- Datatype cells
 timeCell :: IsDBTable m a => UTCTime -> DBCell m a
@@ -70,7 +73,7 @@ courseCellCL (tid,ssh,csh) = anchorCell link name
     name = citext2widget csh
 
 courseCell :: IsDBTable m a => Course -> DBCell m a
-courseCell (Course {..}) = anchorCell link name `mappend` desc
+courseCell Course{..} = anchorCell link name `mappend` desc
   where
     link = CourseR courseTerm courseSchool courseShorthand CShowR
     name = citext2widget courseName
@@ -97,7 +100,7 @@ submissionCell crse shn sid =
       csh = crse ^. _3
       mkCid = encrypt sid
       mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
-      mkText  cid = display2widget cid
+      mkText      = display2widget
   in anchorCellM' mkCid mkRoute mkText
 
 correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a

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

@@ -1,10 +1,15 @@
-{-# LANGUAGE NoImplicitPrelude
-           , ExistentialQuantification
-           , RankNTypes
-           , RecordWildCards
-  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Handler.Utils.Table.Pagination.Types where
+module Handler.Utils.Table.Pagination.Types
+  ( FilterKey, SortingKey
+  , Sortable(..)
+  , sortable
+  , ToSortable(..)
+  , SortableP(..)
+  , SqlIn(..)
+  , sqlInTuples
+  , DBTableInvalid(..)
+  ) where
 
 import Import hiding (singleton)
 
@@ -13,12 +18,30 @@ import Colonnade.Encode
 
 import Data.CaseInsensitive (CI)
 
+import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+
+import Language.Haskell.TH
+
+import Data.List (foldr1, foldl)
+
+
+newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
+  deriving (Show, Read, Generic)
+  deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
+  deriving (Show, Read, Generic)
+  deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+
+
 data Sortable a = Sortable
-  { sortableKey :: Maybe (CI Text)
+  { sortableKey :: Maybe SortingKey
   , sortableContent :: a
   }
 
-sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c
+sortable :: Maybe SortingKey -> c -> (a -> c) -> Colonnade Sortable a c
 sortable k h = singleton (Sortable k h)
 
 instance Headedness Sortable where
@@ -42,3 +65,43 @@ instance ToSortable Headed where
 
 instance ToSortable Headless where
   pSortable = Nothing
+
+
+class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
+  sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
+
+instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
+  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
+
+sqlInTuples :: [Int] -> DecsQ
+sqlInTuples = mapM sqlInTuple
+
+sqlInTuple :: Int -> DecQ
+sqlInTuple arity = do
+  tyVars <- replicateM arity $ newName "t"
+  vVs <- replicateM arity $ newName "v"
+  xVs <- replicateM arity $ newName "x"
+  xsV <- newName "xs"
+
+  let
+    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
+    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
+  
+  instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
+    [ funD 'sqlIn
+      [ clause [tupP $ map varP xVs, varP xsV]
+        ( guardedB
+          [ normalGE [e|null $(varE xsV)|] [e|E.val False|]
+          , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
+          ]
+        ) []
+      ]
+    ]
+
+
+data DBTableInvalid = DBTIRowsMissing Int
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception DBTableInvalid
+
+embedRenderMessage ''UniWorX ''DBTableInvalid id

src/Handler/Utils/Templates.hs

@@ -1,30 +1,30 @@
-{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
-
 module Handler.Utils.Templates where
 
 import Data.Either (isLeft)
 
 import Import
 
-modal :: WidgetT UniWorX IO () -> Either (Route UniWorX) (WidgetT UniWorX IO ()) -> WidgetT UniWorX IO ()
+modal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO ()
 modal modalTrigger modalContent = do
   let modalDynamic = isLeft modalContent
   modalId <- newIdent
   triggerId <- newIdent
   $(widgetFile "widgets/modal")
   case modalContent of
-    -- TODO: refactor this. preferably put svg in separte file somewhere in static?
-    Left route -> [whamlet|
-      $newline never
-      <div .modal__trigger>
-        <a href=@{route} ##{triggerId}>
-          <object type="image/svg+xml" data=@{StaticR img_modal_svg} class=modal__triger-icon>
-          <span .modal__trigger-label>^{modalTrigger}
-    |]
-    Right _ -> [whamlet|
-      $newline never
-      <div .modal__trigger>
-        <div ##{triggerId}>
-          <object type="image/svg+xml" data=@{StaticR img_modal_svg} class=modal__trigger-icon>
-          <span .modal__trigger-label>^{modalTrigger}
-    |]
+    Left  route -> do
+      route' <- toTextUrl route
+      [whamlet|
+        $newline never
+        <div .modal__trigger>
+          <a href=@{route} ##{triggerId}>
+            <object type="image/svg+xml" data=@{StaticR img_modal_svg} class=modal__triger-icon>
+            <span .modal__trigger-label>^{modalTrigger}
+      |]
+    Right _     -> do
+      [whamlet|
+        $newline never
+        <div .modal__trigger>
+          <div ##{triggerId}>
+            <object type="image/svg+xml" data=@{StaticR img_modal_svg} class=modal__trigger-icon>
+            <span .modal__trigger-label>^{modalTrigger}
+      |]

src/Handler/Utils/Zip.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -61,7 +57,7 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
             fileContent
               | hasTrailingPathSeparator zipEntryName = Nothing
               | otherwise = Just $ mconcat contentChunks
-          yield $ File{..}
+          yield File{..}
           consumeZip'
     accContents :: Monad m => Sink (Either a b) m [b]
     accContents = do
@@ -85,7 +81,7 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
       }
 
     toZipData :: Monad m => File -> (ZipEntry, ZipData m)
-    toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
+    toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
 
     toZipEntry :: File -> ZipEntry
     toZipEntry File{..} = ZipEntry

src/Import.hs

@@ -5,3 +5,4 @@ module Import
 import Foundation            as Import
 import Import.NoFoundation   as Import
 
+import Utils.SystemMessage   as Import

src/Import/NoFoundation.hs

@@ -1,18 +1,22 @@
-{-# LANGUAGE CPP #-}
 module Import.NoFoundation
     ( module Import
+    , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
+import Model.Rating           as Import
+import Model.Submission       as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
 import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Utils                  as Import
+import Yesod.Core.Json        as Import (provideJson)
+import Yesod.Core.Types.Instances as Import ()
 
 
 import Data.Fixed             as Import
@@ -25,3 +29,39 @@ import Text.Lucius            as Import
 import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
+import Data.Pool              as Import (Pool)
+import Network.HaskellNet.SMTP as Import (SMTPConnection)
+
+import Mail                   as Import
+
+import Data.Data              as Import (Data)
+import Data.Typeable          as Import (Typeable)
+import GHC.Generics           as Import (Generic)
+import GHC.Exts               as Import (IsList)
+
+import Data.Hashable          as Import
+import Data.List.NonEmpty     as Import (NonEmpty(..))
+import Data.Text.Encoding.Error    as Import(UnicodeException(..))
+import Data.Semigroup         as Import (Semigroup)
+import Data.Monoid            as Import (Last(..), First(..))
+import Data.Monoid.Instances  as Import ()
+
+import Data.Binary            as Import (Binary)
+
+import Control.Monad.Morph    as Import (MFunctor(..))
+
+import Control.Monad.Trans.Resource as Import (ReleaseKey)
+
+import Network.Mail.Mime.Instances as Import ()
+import Yesod.Core.Instances as Import ()
+
+import Ldap.Client.Pool as Import
+
+import Database.Esqueleto.Instances as Import ()
+import Database.Persist.Sql.Instances as Import ()
+import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
+
+
+import Control.Monad.Trans.RWS (RWST)
+
+type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

src/Jobs.hs

@@ -0,0 +1,331 @@
+module Jobs
+  ( module Types
+  , module Jobs.Queue
+  , handleJobs
+  , stopJobCtl
+  ) where
+
+import Import
+
+import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
+import Jobs.Types (JobCtl(JobCtlQueue))
+import Jobs.Queue
+import Jobs.Crontab
+
+import Data.Conduit.TMChan
+import qualified Data.Conduit.List as C
+
+import qualified Data.Text.Lazy as LT
+
+import Data.Aeson (fromJSON, toJSON)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Database.Persist.Sql (fromSqlKey)
+
+import Data.Semigroup (Max(..))
+
+import Utils.Sql
+
+import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
+
+import Cron
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict (HashMap)
+
+import qualified Data.List.NonEmpty as NonEmpty
+
+import qualified Data.Map.Strict as Map
+
+import Data.Foldable (foldrM)
+
+import Control.Monad.Trans.Reader (mapReaderT)
+import Control.Monad.Trans.State (evalStateT, mapStateT)
+import qualified Control.Monad.State.Class as State
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate, release)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Logger
+
+import Data.Time.Clock
+import Data.Time.Zones
+
+import Control.Concurrent.STM (retry)
+
+
+import Jobs.Handler.SendNotification
+import Jobs.Handler.SendTestEmail
+import Jobs.Handler.QueueNotification
+import Jobs.Handler.HelpRequest
+import Jobs.Handler.SetLogSettings
+import Jobs.Handler.DistributeCorrections
+
+  
+data JobQueueException = JInvalid QueuedJobId QueuedJob
+                       | JLocked QueuedJobId InstanceId UTCTime
+                       | JNonexistant QueuedJobId
+  deriving (Read, Show, Eq, Generic, Typeable)
+
+instance Exception JobQueueException
+
+
+handleJobs :: ( MonadResource m
+              , MonadIO m
+              )
+           => UniWorX -> m ()
+-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
+--
+-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
+-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
+handleJobs foundation@UniWorX{..} = do
+  let num = appJobWorkers appSettings
+
+  jobCrontab <- liftIO $ newTMVarIO HashMap.empty
+  jobConfirm <- liftIO $ newTVarIO HashMap.empty
+
+  forM_ [1..num] $ \n -> do
+    (bChan, chan) <- atomically $ newBroadcastTMChan >>= (\c -> (c, ) <$> dupTMChan c)
+    let
+      logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
+      logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
+      removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
+      doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
+    (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
+    atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
+
+  -- Start cron operation
+  registeredCron <- liftIO newEmptyTMVarIO
+  let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
+        unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
+      unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
+  cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
+  registeredCron' <- atomically $ do
+    registeredCron' <- tryPutTMVar appCronThread cData
+    registeredCron' <$ putTMVar registeredCron registeredCron'
+  when registeredCron' $
+    liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+      writeJobCtlBlock JobCtlDetermineCrontab
+
+stopJobCtl :: MonadIO m => UniWorX -> m ()
+-- ^ Stop all worker threads currently running
+stopJobCtl UniWorX{appJobCtl, appCronThread} = do
+  mcData <- atomically $ tryReadTMVar appCronThread
+  whenIsJust mcData $ \(rKey, _) -> do
+    liftIO $ release rKey
+    atomically . guardM $ isEmptyTMVar appCronThread
+  
+  wMap <- liftIO $ readTVarIO appJobCtl
+  atomically $ forM_ wMap closeTMChan
+  atomically $ do
+    wMap' <- readTVar appJobCtl
+    guard . none (`Map.member` wMap') $ Map.keysSet wMap
+
+
+execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
+-- ^ 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 = evalStateT go HashMap.empty
+  where
+    go = do
+      mapStateT (liftHandlerT . runDB . setSerializable) $ do
+        let
+          merge (Entity leId CronLastExec{..})
+            | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+            = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+            | otherwise = lift $ delete leId
+        runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
+
+      refT <- liftIO getCurrentTime
+      settings <- getsYesod appSettings
+      currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
+        crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
+        case crontab' of
+          Nothing -> return Nothing
+          Just crontab -> Just <$> do
+            State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
+            prevExec <- State.get
+            case earliestJob settings prevExec crontab refT of
+              Nothing -> liftBase retry
+              Just (_, MatchNone) -> liftBase retry
+              Just x -> return (crontab, x)
+
+      case currentState of
+        Nothing -> return ()
+        Just (currentCrontab, (jobCtl, nextMatch)) -> do
+          let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
+                  newCrontab <- lift . lift . hoist lift $ determineCrontab'
+                  if
+                    | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
+                      -> do
+                        now <- liftIO $ getCurrentTime
+                        instanceID <- getsYesod appInstanceID
+                        State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+                        case jobCtl of
+                          JobCtlQueue job -> do
+                            void . lift . lift $ upsertBy
+                              (UniqueCronLastExec $ toJSON job)
+                              CronLastExec
+                                { cronLastExecJob = toJSON job
+                                , cronLastExecTime = now
+                                , cronLastExecInstance = instanceID
+                                }
+                              [ CronLastExecTime =. now ]
+                            lift . lift $ queueDBJob job
+                          other -> writeJobCtl other
+                    | otherwise
+                      -> lift . mapReaderT (liftIO . atomically) $
+                           lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
+
+          case nextMatch of
+            MatchAsap -> doJob
+            MatchNone -> return ()
+            MatchAt nextTime -> do
+              JobContext{jobCrontab} <- ask
+              nextTime' <- applyJitter jobCtl nextTime
+              $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
+              logFunc <- askLoggerIO
+              whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
+                doJob
+
+          go
+      where
+        acc :: NominalDiffTime
+        acc = 1e-3
+
+        debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
+        debouncingAcc AppSettings{appNotificationRateLimit} = \case
+          JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
+          _ -> acc
+
+        applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
+        applyJitter seed t = do
+          appInstance <- getsYesod appInstanceID
+          let
+            halfRange = truncate $ 0.5 / acc
+            diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
+          return $ addUTCTime diff t
+
+        earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+        earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
+          where
+            go' (jobCtl, cron) mbPrev
+              | Just (_, t') <- mbPrev
+              , t' < t
+              = mbPrev
+              | otherwise
+              = Just (jobCtl, t)
+              where
+                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
+
+        waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
+        waitUntil crontabTV crontab nextTime = runResourceT $ do
+          diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+          let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+              waitTime'
+                | diffT < acc = "Done"
+                | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+          $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
+          if
+            | diffT < acc -> return True
+            | otherwise   -> do
+                retVar <- liftIO newEmptyTMVarIO
+                void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
+                let
+                  awaitDelayThread = False <$ takeTMVar retVar
+                  awaitCrontabChange = do
+                    crontab' <- tryReadTMVar crontabTV
+                    True <$ guard (Just crontab /= crontab')
+                crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+                bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+
+
+handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) ()
+handleJobs' wNum = C.mapM_ $ \jctl -> do
+  $logDebugS logIdent $ tshow jctl
+  resVars <- mapReaderT (liftIO . atomically) $
+    HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
+  res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
+  sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
+  case res of
+    Just err
+      | not sentRes -> $logErrorS logIdent $ tshow err
+    _other -> return ()
+  where
+    logIdent = "Jobs #" <> tshow wNum
+    
+    handleQueueException :: MonadLogger m => JobQueueException -> m ()
+    handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
+    handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
+    handleQueueException (JLocked jId lInstance lTime)  = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
+
+    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
+    handleCmd (JobCtlQueue job) = lift $ queueJob' job
+    handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
+      content <- case fromJSON queuedJobContent of
+        Aeson.Success c -> return c
+        Aeson.Error t -> do
+          $logErrorS logIdent $ "Aeson decoding error: " <> pack t
+          throwM $ JInvalid jId j
+      
+      $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
+
+      performJob content
+
+      -- `performJob` is expected to throw an exception if it detects that the job was not done
+      runDB $ delete jId
+    handleCmd JobCtlDetermineCrontab = do
+      newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
+      -- logDebugS logIdent $ tshow newCTab
+      mapReaderT (liftIO . atomically) $ 
+        lift . void . flip swapTMVar newCTab =<< asks jobCrontab
+
+jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
+jLocked jId act = do
+  hasLock <- liftIO $ newTVarIO False
+
+  let
+    lock = runDB . setSerializable $ do
+      qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
+      instanceID <- getsYesod appInstanceID
+      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      now <- liftIO getCurrentTime
+      hadStale <- maybeT (return False) $ do
+        lockTime <- MaybeT $ return queuedJobLockTime
+        lockInstance <- MaybeT $ return queuedJobLockInstance
+        if
+          | lockInstance == instanceID
+          , diffUTCTime now lockTime >= threshold
+            -> return True
+          | otherwise
+            -> throwM $ JLocked jId lockInstance lockTime
+      when hadStale .
+        $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
+      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
+                           , QueuedJobLockTime =. Just now
+                           ]
+      liftIO . atomically $ writeTVar hasLock True
+      return val
+
+    unlock = whenM (liftIO . atomically $ readTVar hasLock) $
+      runDB . setSerializable $
+        update jId [ QueuedJobLockInstance =. Nothing
+                   , QueuedJobLockTime =. Nothing
+                   ]
+      
+  bracket lock (const unlock) act
+
+
+pruneLastExecs :: Crontab JobCtl -> DB ()
+pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
+  where
+    ensureCrontab (Entity leId CronLastExec{..})
+      | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+      , HashMap.member (JobCtlQueue job) crontab
+      = return ()
+      | otherwise = delete leId
+
+determineCrontab' :: DB (Crontab JobCtl)
+determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
+
+
+performJob :: Job -> HandlerT UniWorX IO ()
+performJob = $(dispatchTH ''Job)

src/Jobs/Crontab.hs

@@ -0,0 +1,107 @@
+module Jobs.Crontab
+  ( determineCrontab
+  ) where
+
+import Import
+
+import qualified Data.HashMap.Strict as HashMap
+import Jobs.Types
+
+import Data.Maybe (fromJust)
+import qualified Data.Map as Map
+import Data.Semigroup (Max(..))
+
+import Data.Time
+import Data.Time.Zones
+
+import Control.Monad.Trans.Writer (execWriterT)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import qualified Data.Conduit.List as C
+
+
+determineCrontab :: DB (Crontab JobCtl)
+-- ^ Extract all future jobs from the database (sheet deadlines, ...)
+determineCrontab = execWriterT $ do
+  AppSettings{..} <- getsYesod appSettings
+
+  case appJobFlushInterval of
+    Just interval -> tell $ HashMap.singleton
+      JobCtlFlush
+      Cron
+        { cronInitial = CronAsap
+        , cronRepeat = CronRepeatScheduled CronAsap
+        , cronRateLimit = interval
+        , cronNotAfter = Right CronNotScheduled
+        }
+    Nothing -> return ()
+
+  tell $ HashMap.singleton
+    JobCtlDetermineCrontab
+    Cron
+      { cronInitial = CronAsap
+      , cronRepeat = CronRepeatScheduled CronAsap
+      , cronRateLimit = appJobCronInterval
+      , cronNotAfter = Right CronNotScheduled
+      }
+
+  let
+    sheetJobs (Entity nSheet Sheet{..}) = do
+      tell $ HashMap.singleton
+        (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
+        Cron
+          { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
+          , cronRepeat = CronRepeatNever
+          , cronRateLimit = appNotificationRateLimit
+          , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
+          }
+      tell $ HashMap.singleton
+        (JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
+        Cron
+          { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
+          , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
+          , cronRateLimit = appNotificationRateLimit
+          , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
+          }
+      tell $ HashMap.singleton
+        (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
+        Cron
+          { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
+          , cronRepeat    = CronRepeatOnChange
+          , cronRateLimit = appNotificationRateLimit
+          , cronNotAfter  = Left appNotificationExpiration
+          }             
+      when sheetAutoDistribute $
+        tell $ HashMap.singleton
+          (JobCtlQueue $ JobDistributeCorrections nSheet)
+          Cron
+            { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
+            , cronRepeat    = CronRepeatNever
+            , cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
+            , cronNotAfter  = Left nominalDay
+            }
+      
+      sheetSubmissions <- lift $ collateSubmissions <$> 
+          selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []      
+      tell $ flip Map.foldMapWithKey sheetSubmissions $
+        \nUser (Max mbTime) -> if
+          |  Just time <- mbTime -> HashMap.singleton 
+              (JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
+              Cron 
+                { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
+                , cronRepeat    = CronRepeatNever
+                , cronRateLimit = appNotificationRateLimit
+                , cronNotAfter  = Left appNotificationExpiration
+                }
+          | otherwise -> mempty
+
+  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
+
+-- | Partial function: Submission must not have Nothing at ratingBy
+collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
+collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
+    where 
+      procCorrector :: Entity Submission -> (UserId ,Max (Maybe UTCTime))
+      procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal 
+                          <*> Max . submissionRatingAssigned . entityVal
+      

src/Jobs/Handler/DistributeCorrections.hs

@@ -0,0 +1,21 @@
+module Jobs.Handler.DistributeCorrections
+  ( dispatchJobDistributeCorrections
+  ) where
+
+import Import
+
+import Jobs.Queue
+
+import Control.Monad.Trans.Reader (mapReaderT)
+
+import Handler.Utils.Submission
+
+import qualified Data.Set as Set
+
+
+dispatchJobDistributeCorrections :: SheetId
+                                 -> Handler ()
+dispatchJobDistributeCorrections jSheet = runDBJobs $ do
+  (_, unassigned) <- mapReaderT lift $ assignSubmissions jSheet Nothing
+  unless (Set.null unassigned) $
+    queueDBJob . JobQueueNotification $ NotificationCorrectionsNotDistributed jSheet

src/Jobs/Handler/HelpRequest.hs

@@ -0,0 +1,35 @@
+module Jobs.Handler.HelpRequest
+  ( dispatchJobHelpRequest
+  ) where
+
+import Import
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+import Handler.Utils
+
+import Utils.Lens
+
+import Data.Bitraversable
+  
+
+dispatchJobHelpRequest :: Either (Maybe Address) UserId
+                       -> UTCTime
+                       -> Text -- ^ Help Request
+                       -> Maybe Text -- ^ Referer
+                       -> Handler ()
+dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
+  supportAddress <- getsYesod $ appMailSupport . appSettings
+  userInfo <- bitraverse return (runDB . getEntity) jSender
+  let userAddress = either
+        id
+        (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
+        userInfo
+  mailT def $ do
+    _mailTo .= [supportAddress]
+    whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
+    setSubjectI MsgMailSubjectSupport
+    setDate jRequestTime
+    rtime <- formatTimeMail SelFormatDateTime jRequestTime
+    addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/QueueNotification.hs

@@ -0,0 +1,69 @@
+module Jobs.Handler.QueueNotification
+  ( dispatchJobQueueNotification
+  ) where
+
+import Import
+
+import Jobs.Types
+
+import qualified Database.Esqueleto as E
+import Utils.Sql
+import Jobs.Queue
+
+
+dispatchJobQueueNotification :: Notification -> Handler ()
+dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
+  candidates <- hoist lift $ determineNotificationCandidates jNotification
+  nClass <- hoist lift $ classifyNotification jNotification
+  mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do
+    Entity uid User{userNotificationSettings} <- candidates
+    guard $ notificationAllowed userNotificationSettings nClass
+    return uid
+
+  
+determineNotificationCandidates :: Notification -> DB [Entity User]
+determineNotificationCandidates NotificationSubmissionRated{..}
+  = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
+      E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
+      return user
+determineNotificationCandidates NotificationSheetActive{..}
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
+determineNotificationCandidates NotificationSheetSoonInactive{..}
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
+determineNotificationCandidates NotificationSheetInactive{..}
+  = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do  
+      E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse 
+      E.on $ lecturer E.^. LecturerUser   E.==. user E.^. UserId
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
+determineNotificationCandidates NotificationCorrectionsAssigned{..}
+  = selectList [UserId ==. nUser] [] 
+determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet}
+  = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
+      E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
+      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
+  
+classifyNotification :: Notification -> DB NotificationTrigger
+classifyNotification NotificationSubmissionRated{..} = do
+  Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
+  return $ case sheetType of
+    NotGraded -> NTSubmissionRated
+    _other -> NTSubmissionRatedGraded
+classifyNotification NotificationSheetActive{} = return NTSheetActive
+classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
+classifyNotification NotificationSheetInactive{} = return NTSheetInactive
+classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
+classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
+
+

src/Jobs/Handler/SendNotification.hs

@@ -0,0 +1,18 @@
+module Jobs.Handler.SendNotification
+  ( dispatchJobSendNotification
+  ) where
+
+import Import
+
+import Jobs.Types
+
+
+import Jobs.Handler.SendNotification.SubmissionRated
+import Jobs.Handler.SendNotification.SheetActive
+import Jobs.Handler.SendNotification.SheetInactive
+import Jobs.Handler.SendNotification.CorrectionsAssigned
+import Jobs.Handler.SendNotification.CorrectionsNotDistributed
+
+
+dispatchJobSendNotification :: UserId -> Notification -> Handler ()
+dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.CorrectionsAssigned
+  ( dispatchNotificationCorrectionsAssigned
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
+dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
+  (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    nbrSubs <- count [ SubmissionSheet      ==. nSheet
+                     , SubmissionRatingBy   ==. Just nUser
+                     , SubmissionRatingTime ==. Nothing
+                     ]
+    return (course, sheet, nbrSubs)
+  when (nbrSubs > 0) . userMailT jRecipient $ do 
+    setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
+
+    MsgRenderer mr <- getMailMsgRenderer
+    let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+
+    addAlternatives $ do
+      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+      providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

@@ -0,0 +1,31 @@
+module Jobs.Handler.SendNotification.CorrectionsNotDistributed
+  ( dispatchNotificationCorrectionsNotDistributed
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
+dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
+  (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    nbrSubs <- count [ SubmissionSheet      ==. nSheet
+                     , SubmissionRatingBy   ==. Nothing
+                     ]
+    return (course, sheet, nbrSubs)
+  when (nbrSubs > 0) . userMailT jRecipient $ do 
+    setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
+    MsgRenderer mr <- getMailMsgRenderer
+    let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+        tid = courseTerm
+        ssh = courseSchool
+        csh = courseShorthand
+        shn = sheetName
+
+    addAlternatives $
+      providePreferredAlternative ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.SheetActive
+  ( dispatchNotificationSheetActive
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSheetActive :: SheetId -> UserId -> Handler ()
+dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet)
+  setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  addAlternatives $ do
+    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -0,0 +1,52 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.SheetInactive
+  ( dispatchNotificationSheetSoonInactive
+  , dispatchNotificationSheetInactive
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler ()
+dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet)
+  setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  addAlternatives $ do
+    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+
+dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
+dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet)
+  setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  addAlternatives $ do
+    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.SubmissionRated
+  ( dispatchNotificationSubmissionRated
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils.DateTime
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.Aeson as Aeson
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
+dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
+    submission@Submission{submissionRatingBy} <- getJust nSubmission
+    sheet <- belongsToJust submissionSheet submission
+    course <- belongsToJust sheetCourse sheet
+    corrector <- traverse getJust submissionRatingBy
+    return (course, sheet, submission, corrector)
+  setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
+
+  csid <- encrypt nSubmission
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+  let sheetTypeDesc = mr sheetType
+  submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
+  let tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  -- TODO: provide convienience template-haskell for `addAlternatives`
+  addAlternatives $ do
+    provideAlternative $ Aeson.object
+      [ "submission" Aeson..= ciphertext csid
+      , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
+      , "submission-rating-comment" Aeson..= submissionRatingComment
+      , "submission-rating-time" Aeson..= submissionRatingTime
+      , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
+      , "submission-rating-passed" Aeson..= join (gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)      
+      , "sheet-name" Aeson..= sheetName
+      , "sheet-type" Aeson..= sheetType
+      , "course-name" Aeson..= courseName
+      , "course-shorthand" Aeson..= courseShorthand
+      , "course-term" Aeson..= courseTerm
+      , "course-school" Aeson..= courseSchool
+      ]
+    -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
+    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendTestEmail.hs

@@ -0,0 +1,28 @@
+module Jobs.Handler.SendTestEmail
+  ( dispatchJobSendTestEmail
+  ) where
+
+import Import 
+
+import Handler.Utils.DateTime
+
+import Text.Shakespeare.Text
+
+import Utils.Lens
+
+dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
+dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
+  _mailTo .= [Address Nothing jEmail]
+  setSubjectI MsgMailTestSubject
+  now <- liftIO getCurrentTime
+  nDT <- formatTimeMail SelFormatDateTime now
+  nD <- formatTimeMail SelFormatDate now
+  nT <- formatTimeMail SelFormatTime now
+  addPart $ \(MsgRenderer mr) -> ([text|
+    #{mr MsgMailTestContent}
+
+    #{mr MsgMailTestDateTime}
+      * #{nDT}
+      * #{nD}
+      * #{nT}
+    |] :: TextUrl (Route UniWorX))