Merge branch 'master' into 'live'

Master

Closes #203, #193, #212, #118, #204, #207, #202, and #198

See merge request !82

.gitignore

@@ -29,6 +29,7 @@ uniworx.nix
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
+/instance
 .stack-work-*
 .directory
 tags

.vscode/tasks.json

@@ -0,0 +1,16 @@
+{
+    // See https://go.microsoft.com/fwlink/?LinkId=733558
+    // for the documentation about the tasks.json format
+    "version": "2.0.0",
+    "tasks": [
+        {
+            "label": "echo",
+            "type": "shell",
+            "command": "echo Hello",
+            "group": {
+                "kind": "build",
+                "isDefault": true
+            }
+        }
+    ]
+}

ChangeLog.md

@@ -1,3 +1,11 @@
+  * 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

README.md

@@ -83,6 +83,10 @@ The following Description applies to Ubuntu or similar.
   ldap:  https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/
 
 
+Instead of run.sh, use:
+stack build --flag uniworx:dev --flag uniworx:library-only
+
+
 ***
 
 # PostgreSQL

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
+    start done = runResourceT $ do
-        (port, site, app) <- getApplicationRepl
+      (port, site, app) <- getApplicationRepl
-        forkIO (finally (runSettings (setPort port defaultSettings) app)
+      resourceForkIO $ do
-                        -- Note that this implies concurrency
+        finally (liftIO $ runSettings (setPort port defaultSettings) app)
-                        -- between shutdownApp and the next app that is starting.
+          -- Note that this implies concurrency
-                        -- Normally this should be fine
+          -- between shutdownApp and the next app that is starting.
-                        (putMVar done () >> shutdownApp site))
+          -- Normally this should be fine
+          (liftIO $ putMVar done () >> shutdownApp site)
 
 -- | kill the server
 shutdown :: IO ()

config/keter_testworx.yml

@@ -31,9 +31,21 @@ stanzas:
       - 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
 
 # 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

@@ -30,9 +30,22 @@ stanzas:
       - LDAPTIMEOUT
       - 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
+
 
 # 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,31 @@ 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:         null
+  email:        "uni2work@ifi.lmu.de"
 
-detailed-logging:  "_env:DETAILED_LOGGING:false"
+job-workers:        "_env:JOB_WORKERS:10"
-should-log-all:    "_env:LOG_ALL:false"
+job-flush-interval: "_env:JOB_FLUSH:30"
-minimum-log-level: "_env:LOGLEVEL:warn"
+job-cron-interval:  "_env:CRON_INTERVAL:60"
+job-stale-threshold: 300
+notification-rate-limit: 3600
+notification-collate-delay: 300
+notification-expiration: 259201
+
+log-settings:
+  log-detailed:      "_env:DETAILED_LOGGING:false"
+  log-all:           "_env:LOG_ALL:false"
+  log-minimum-level: "_env:LOGLEVEL:warn"
+
+# Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
 
@@ -44,6 +65,19 @@ ldap:
   scope:   "_env:LDAPSCOPE:WholeSubtree"
   timeout: "_env:LDAPTIMEOUT:5"
 
+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"
+
 user-defaults:
   max-favourites:   12
   theme:            Default
@@ -53,3 +87,4 @@ user-defaults:
   download-files:   false
 
 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
+instance-idfile: "_env:INSTANCEID_FILE:instance"

db.hs

@@ -1,11 +1,12 @@
 #!/usr/bin/env stack
--- stack runghc
+-- stack runghc --package uniworx
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 
 import "uniworx" Import hiding (Option(..))
 import "uniworx" Application (db, getAppDevSettings)
@@ -20,6 +21,8 @@ import System.IO (hPutStrLn, stderr)
 
 import qualified Data.ByteString as BS
 
+import Database.Persist.Sql (toSqlKey)
+
 import Data.Time
 
 
@@ -62,6 +65,8 @@ fillDb = do
   AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
   now <- liftIO getCurrentTime
   let
+    insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
+    insert' = fmap (either entityKey id) . insertBy
     summer2017 = TermIdentifier 2017 Summer
     winter2017 = TermIdentifier 2017 Winter
     summer2018 = TermIdentifier 2018 Summer
@@ -78,6 +83,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["en"]
+    , userNotificationSettings = def
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
@@ -92,6 +99,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
@@ -106,8 +115,10 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
-  void . insert $ User
+  maxMuster <- insert User
     { userIdent  = "max@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userMatrikelnummer = Nothing
@@ -120,6 +131,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
   void . insert $ User
     { userIdent  = "tester@campus.lmu.de"
@@ -134,8 +147,10 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
-  void . insert $ Term
+  void . repsert (TermKey summer2017) $ Term
     { termName     = summer2017
     , termStart    = fromGregorian 2017 04 09
     , termEnd      = fromGregorian 2017 07 14
@@ -144,7 +159,7 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 07 14
     , termActive       = False
     }
-  void . insert $ Term
+  void . repsert (TermKey winter2017) $ Term
     { termName     = winter2017
     , termStart    = fromGregorian 2017 10 16
     , termEnd      = fromGregorian 2018 02 10
@@ -153,7 +168,7 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 02 10
     , termActive       = True
     }
-  void . insert $ Term
+  void . repsert (TermKey summer2018) $ Term
     { termName     = summer2018
     , termStart    = fromGregorian 2018 04 09
     , termEnd      = fromGregorian 2018 07 14
@@ -162,22 +177,28 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 07 14
     , termActive       = True
     }
-  ifi <- insert $ School "Institut für Informatik" "IfI"
+  ifi <- insert' $ School "Institut für Informatik" "IfI"
-  mi <- insert $ School "Institut für Mathematik" "MI"
+  mi <- insert' $ School "Institut für Mathematik" "MI"
-  void . insert $ UserAdmin gkleen ifi
+  void . insert' $ UserAdmin gkleen ifi
-  void . insert $ UserAdmin gkleen mi
+  void . insert' $ UserAdmin gkleen mi
-  void . insert $ UserAdmin fhamann ifi
+  void . insert' $ UserAdmin fhamann ifi
-  void . insert $ UserAdmin jost ifi
+  void . insert' $ UserAdmin jost ifi
-  void . insert $ UserAdmin jost mi
+  void . insert' $ UserAdmin jost mi
-  void . insert $ UserLecturer gkleen ifi
+  void . insert' $ UserLecturer gkleen ifi
-  void . insert $ UserLecturer fhamann ifi
+  void . insert' $ UserLecturer fhamann ifi
-  void . insert $ UserLecturer jost ifi
+  void . insert' $ UserLecturer jost ifi
-  sdBsc  <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  let
-  sdMst  <- insert $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+    sdBsc = StudyDegreeKey' 82
-  sdInf  <- insert $ StudyTerms  79 (Just "Inf") (Just "Informatik")
+    sdMst = StudyDegreeKey' 88
-  sdMath <- insert $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
+  repsert sdBsc  $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  repsert sdMst  $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+  let
+    sdInf  = StudyTermsKey' 79
+    sdMath = StudyTermsKey' 105
+  repsert sdInf  $ StudyTerms  79 (Just "IfI") (Just "Institut für Informatik")
+  repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
   -- FFP
-  ffp <- insert Course
+  ffp <- insert' Course
     { courseName = "Fortgeschrittene Funktionale Programmierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -186,7 +207,7 @@ fillDb = do
     , courseSchool = ifi
     , courseCapacity = Just 20
     , courseRegisterFrom = Just now
-    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseRegisterTo = Just (nominalDay `addUTCTime` now )
     , courseDeregisterUntil = Nothing
     , courseRegisterSecret  = Nothing
     , courseMaterialFree    = True
@@ -196,14 +217,14 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
+  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
+  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
+  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
-  eip <- insert Course
+  eip <- insert' Course
     { courseName = "Einführung in die Programmierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -218,10 +239,10 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now eip
-  void . insert $ DegreeCourse eip sdBsc sdInf
+  void . insert' $ DegreeCourse eip sdBsc sdInf
-  void . insert $ Lecturer fhamann eip
+  void . insert' $ Lecturer fhamann eip
   -- interaction design
-  ixd <- insert Course
+  ixd <- insert' Course
     { courseName = "Interaction Design (User Experience Design I & II)"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -230,16 +251,16 @@ fillDb = do
     , courseSchool = ifi
     , courseCapacity = Just 20
     , courseRegisterFrom = Just now
-    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseRegisterTo = Just (nominalDay `addUTCTime` now )
     , courseDeregisterUntil = Nothing
     , courseRegisterSecret  = Nothing
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ixd
-  void . insert $ DegreeCourse ixd sdBsc sdInf
+  void . insert' $ DegreeCourse ixd sdBsc sdInf
-  void . insert $ Lecturer fhamann ixd
+  void . insert' $ Lecturer fhamann ixd
   -- concept development
-  ux3 <- insert Course
+  ux3 <- insert' Course
     { courseName = "Concept Development (User Experience Design III)"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -254,10 +275,10 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ux3
-  void . insert $ DegreeCourse ux3 sdBsc sdInf
+  void . insert' $ DegreeCourse ux3 sdBsc sdInf
-  void . insert $ Lecturer fhamann ux3
+  void . insert' $ Lecturer fhamann ux3
   -- promo
-  pmo <- insert Course
+  pmo <- insert' Course
     { courseName = "Programmierung und Modellierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -284,6 +305,7 @@ fillDb = do
     , sheetVisibleFrom = Just now
     , sheetActiveFrom = now
     , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetSubmissionMode = CorrectorSubmissions
     , sheetUploadMode = Upload True
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
@@ -297,8 +319,14 @@ fillDb = do
   void . insert $ SheetFile sh1 h102 SheetHint
   void . insert $ SheetFile sh1 h103 SheetSolution
   void . insert $ SheetFile sh1 pdf10 SheetExercise
+  --
+  sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing
+  void . insert $ SubmissionEdit maxMuster (nominalDay `addUTCTime` now) sub1
+  void . insert $ SubmissionUser maxMuster sub1
+  sub1fid1 <- insertFile "AbgabeH10-1.hs"
+  void . insert $ SubmissionFile sub1 sub1fid1 False False
   -- datenbanksysteme
-  dbs <- insert Course
+  dbs <- insert' Course
     { courseName = "Datenbanksysteme"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -313,7 +341,7 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit gkleen now dbs
-  void . insert $ DegreeCourse dbs sdBsc sdInf
+  void . insert' $ DegreeCourse dbs sdBsc sdInf
-  void . insert $ DegreeCourse dbs sdBsc sdMath
+  void . insert' $ DegreeCourse dbs sdBsc sdMath
-  void . insert $ Lecturer gkleen dbs
+  void . insert' $ Lecturer gkleen dbs
-  void . insert $ Lecturer jost   dbs
+  void . insert' $ Lecturer jost   dbs

ghci.sh

@@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then
     trap move-back EXIT
 fi
 
-stack ghci --flag uniworx:dev --flag uniworx:library-only
+stack ghci --flag uniworx:dev --flag uniworx:library-only ${@}

messages/uniworx/de.msg

@@ -16,7 +16,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
@@ -91,6 +91,7 @@ SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w
 SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
 
 SheetUploadMode: Abgabe von Dateien
+SheetSubmissionMode: Abgabe-Modus
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
 SheetHintFrom: Hinweis ab
@@ -111,6 +112,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,7 +131,7 @@ 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
@@ -155,11 +158,15 @@ 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
+UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
+UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
 UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
 
 EMail: E-Mail
@@ -193,8 +200,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
@@ -245,10 +254,13 @@ RatingComment: Kommentar
 SubmissionUsers: Studenten
 Rating: Korrektur
 RatingPoints: Punkte
+RatingDone: Bewertung fertiggestellt
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
+ColumnRatingPointsDone: Punktzahl/Abgeschlossen
+Pseudonyms: Pseudonyme
 
 FileTitle: Dateiname
 FileModified: Letzte Änderung
@@ -274,6 +286,7 @@ 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
 
 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
@@ -305,7 +318,126 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken
 
+SheetNoSubmission: Keine Abgabe
+SheetCorrectorSubmissions: Abgaben durch Korrektoren
+SheetUserSubmissions: Direkte Abgabe
+
 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.
+
+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: Abgabfristt für #{sheetName} in #{csh} abgelaufen
+MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
+MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
+MailEditNotifications: Benachrichtigungen ein-/ausschalten
+MailSubjectSupport: Supportanfrage
+
+SheetTypeBonus: Bonus
+SheetTypeNormal: Normal
+SheetTypePass: Bestehen
+SheetTypeNotGraded: Keine Wertung
+
+SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte
+SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte
+SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
+SheetTypeNotGraded': Nicht gewertet
+
+SheetTypeMaxPoints: Maximalpunktzahl
+SheetTypePassingPoints: 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
+NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
+
+CorrCreate: Abgaben erstellen
+UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
+InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
+UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}"
+CorrectionPseudonyms: Abgaben-Pseudonyme
+CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile
+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)

models

@@ -11,6 +11,8 @@ User json
     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
@@ -109,11 +111,18 @@ Sheet
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
     uploadMode      UploadMode
+    submissionMode  SheetSubmissionMode default='UserSubmissions'
     CourseSheet course name
 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
@@ -150,7 +159,7 @@ SubmissionFile
     isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
     UniqueSubmissionFile file submission isUpdate
     deriving Show
-SubmissionUser
+SubmissionUser                   -- Actual submission participant
     user            UserId
     submission      SubmissionId
     UniqueSubmissionUser user submission
@@ -161,7 +170,7 @@ SubmissionGroupEdit
     user            UserId
     time            UTCTime
     submissionGroup SubmissionGroupId
-SubmissionGroupUser
+SubmissionGroupUser              -- Registered submission groups, independent of actual SubmissionUser
     submissionGroup     SubmissionGroupId
     user                UserId
     UniqueSubmissionGroupUser submissionGroup   user
@@ -221,3 +230,29 @@ Exam
 --    -- 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)
+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
+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

package.yaml

@@ -77,6 +77,9 @@ dependencies:
 - parsec
 - uuid
 - exceptions
+- stm
+- stm-chans
+- stm-conduit
 - lens
 - MonadRandom
 - email-validate
@@ -90,8 +93,20 @@ dependencies:
 - 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
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -37,6 +37,7 @@
 /admin/user/#CryptoUUIDUser AdminUserR        GET
 /admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
 /info                       VersionR          GET             !free
+/help                       HelpR             GET POST        !free
 
 /profile                    ProfileR          GET POST        !free                             !free
 /profile/data               ProfileDataR      GET POST        !free                             !free
@@ -72,7 +73,7 @@
     /edit                       SEditR        GET POST
     /delete                     SDelR         GET POST
     /subs                       SSubsR        GET POST        -- for lecturer only
-    /subs/new                   SubmissionNewR GET POST        !timeANDregistered
+    /subs/new                   SubmissionNewR GET POST        !timeANDregisteredANDuser-submissions
     /subs/own                   SubmissionOwnR GET             !free -- just redirect
     /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
       /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
@@ -80,11 +81,18 @@
       /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
+    /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 
-/corrections  CorrectionsR GET POST !corrector !lecturer
+/submissions  CorrectionsR GET POST !corrector !lecturer
-/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
+/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
+/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
+
+
+/msgs                           MessageListR GET POST
+/msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDisReadANDauthentication
 
 
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect

src/Application.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
     ( getApplicationDev, getAppDevSettings
@@ -13,6 +14,7 @@ module Application
     , makeFoundation
     , makeLogWare
     -- * for DevelMain
+    , foundationStoreNum
     , getApplicationRepl
     , shutdownApp
     -- * for GHCI
@@ -21,7 +23,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
@@ -38,12 +40,34 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 
+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.ByteString.Lazy as LBS
-import qualified Data.Yaml as Yaml
 
+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 all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -58,6 +82,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,70 +94,140 @@ 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 :: (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
+    appLogger <- liftIO $ do
-    appStatic <-
+      tgetter <- newTimeCache "%Y-%m-%d %T %z"
-        (if appMutableStatic then staticDevel else static)
+      loggerSet <- newStdoutLoggerSet defaultBufSize
-        appStaticDir
+      return $ Yesod.Logger loggerSet tgetter
+    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
 
     appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
+    appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
+
+    (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
+        chan <- newBroadcastTMChan
+        recvChan <- dupTMChan chan
+        return (chan, recvChan)
+
+    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
 
     -- 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 = 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"
+        tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
         logFunc = messageLoggerSource tempFoundation appLogger
 
-    -- Create the database connection pool
+    flip runLoggingT logFunc $ do
-    pool <- flip runLoggingT logFunc $ createPostgresqlPool
+      $logDebugS "InstanceID" $ UUID.toText appInstanceID
+      -- $logDebugS "Configuration" $ tshow appSettings
+
+      smtpPool <- traverse createSmtpPool appSmtpConf
+
+      -- Create the database connection pool
+      sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
+    
+      -- Perform database migration using our application's logging settings.
+      migrateAll `runSqlPool` sqlPool
 
-    -- Perform database migration using our application's logging settings.
+      handleJobs recvChans $ mkFoundation sqlPool smtpPool
-    runLoggingT (runSqlPool migrateAll pool) logFunc
 
-    -- Return the foundation
+      -- Return the foundation
-    return $ mkFoundation pool
+      return $ mkFoundation sqlPool smtpPool
+
+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
+      when (not authSuccess) $ do
+        fail "SMTP authentication failed"
+      return conn
+  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
-makeApplication :: UniWorX -> IO Application
+makeApplication :: MonadIO m => UniWorX -> m Application
-makeApplication foundation = do
+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 :: MonadIO m => UniWorX -> m Middleware
-makeLogWare foundation =
+makeLogWare app = do
-    mkRequestLogger def
+  logWareMap <- liftIO $ newTVarIO HashMap.empty
-        { outputFormat =
-            if appDetailedRequestLogging $ appSettings foundation
-                then Detailed True
-                else Apache
-                        (if appIpFromHeader $ appSettings foundation
-                            then FromFallback
-                            else FromSocket)
-        , destination = Logger $ loggerSet $ appLogger foundation
-        }
 
+  let
+    mkLogWare ls@LogSettings{..} = do
+      logWare <- mkRequestLogger def
+        { outputFormat = bool
+            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Detailed True)
+            logDetailed
+        , destination = Logger . loggerSet $ appLogger app
+        }
+      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 =
+warpSettings foundation = defaultSettings
-      setPort (appPort $ appSettings foundation)
+    & setPort (appPort $ appSettings foundation)
-    $ setHost (appHost $ appSettings foundation)
+    & setHost (appHost $ appSettings foundation)
-    $ setOnException (\_req e ->
+    & setOnException (\_req e ->
         when (defaultShouldDisplayException e) $ messageLoggerSource
             foundation
             (appLogger foundation)
@@ -140,29 +235,30 @@ warpSettings foundation =
             "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 :: MonadIO m => m AppSettings
-getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+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 :: MonadResourceBase m => m ()
-appMain = do
+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 +272,31 @@ 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 :: MonadIO m => UniWorX -> m ()
-shutdownApp _ = return ()
+shutdownApp UniWorX{..} = do
+  liftIO . atomically $ mapM_ closeTMChan appJobCtl
 
 
 ---------------------------------------------
@@ -200,7 +305,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 +314,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/Cron.hs

@@ -0,0 +1,258 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , PatternGuards
+           , ViewPatterns
+           , DeriveFunctor
+           , TemplateHaskell
+           , NamedFieldPuns
+  #-}
+
+module Cron
+  ( 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 Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+
+import Utils.Lens.TH
+import Control.Lens
+
+  
+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 set) x = Set.member x $ toNullable set
+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 set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set
+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
+      | a >  b = 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
+      | a >  b = b : merge (a:as) bs
+
+nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
+              -> Maybe UTCTime -- ^ Time of last execution of the job
+              -> UTCTime -- ^ Current time, used only for `CronCalendar`
+              -> Cron
+              -> CronNextMatch UTCTime
+nextCronMatch tz mPrev 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
+    nextMatch = nextCronMatch' tz mPrev now c
+    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
+          MatchAt t -> Just t
+          MatchNone -> Nothing
+    
+    nextCronMatch' tz mPrev now c@Cron{..}
+      | isNothing mPrev
+      = execRef now False cronInitial
+      | Just prevT <- mPrev
+      = case cronRepeat of
+          CronRepeatOnChange
+            | not $ matchesCron tz Nothing 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
+                 cronNext
+                   -> 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
+        cronYear <- genMatch 400 False cdYear cronYear
+        cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
+        cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
+        cronMonth <- genMatch 12 True cdMonth cronMonth
+        cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
+        cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
+        cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
+        cronHour <- genMatch 24 True cdHour cronHour
+        cronMinute <- genMatch 60 True cdMinute cronMinute
+        cronSecond <- genMatch 60 True cdSecond cronSecond
+        guard $ consistentCronDate CronDate{..}
+        localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
+        let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
+        return $ localTimeToUTCTZ tz LocalTime{..}
+      CronNotScheduled -> MatchNone
+
+matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
+            -> Maybe UTCTime -- ^ Previous execution of the job
+            -> 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 now cron = case nextCronMatch tz mPrev now cron of
+  MatchAsap -> True
+  MatchNone -> False
+  MatchAt ts -> ts <= now

src/Cron/Types.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , DuplicateRecordFields
+  #-}
+
+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

@@ -38,6 +38,9 @@ import qualified Data.CaseInsensitive as CI
 decCryptoIDs [ ''SubmissionId
              , ''FileId
              , ''UserId
+             , ''SheetId
+             , ''SystemMessageId
+             , ''SystemMessageTranslationId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

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

@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# 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,30 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# 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/Foundation.hs

@@ -20,12 +20,12 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
 
--- Used only when in "auth-dummy-login" setting is enabled.
 import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
+import Jobs.Types
 
 import qualified Network.Wai as W (requestMethod, pathInfo)
 
@@ -56,9 +56,11 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
+import Data.List (findIndex)
 
 import Data.Monoid (Any(..))
 
+import Data.Pool
 
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
@@ -67,7 +69,7 @@ import qualified Database.Esqueleto as E
 
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
-import Control.Monad.Trans.Reader (runReader)
+import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Catch (handleAll)
@@ -81,13 +83,19 @@ import Control.Lens
 import Utils
 import Utils.Form
 import Utils.Lens
+import Utils.SystemMessage
 
-import Data.Aeson hiding (Error)
+import Data.Aeson hiding (Error, Success)
 import Data.Aeson.TH
 import qualified Data.Yaml as Yaml
 
 import Text.Shakespeare.Text (st)
 
+import Yesod.Form.I18n.German
+import qualified Yesod.Auth.Message as Auth
+
+import qualified Data.Conduit.List as C
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -112,11 +120,17 @@ data UniWorX = UniWorX
     { appSettings    :: AppSettings
     , appStatic      :: Static -- ^ Settings for static file serving.
     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
+    , appSmtpPool    :: Maybe SMTPPool
     , appHttpManager :: Manager
     , appLogger      :: Logger
+    , appLogSettings :: TVar LogSettings
     , appCryptoIDKey :: CryptoIDKey
+    , appInstanceID  :: InstanceId
+    , appJobCtl      :: [TMChan JobCtl]
     }
 
+type SMTPPool = Pool SMTPConnection
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -135,6 +149,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
 type DB a = YesodDB UniWorX a
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
+type MailM a = MailT (HandlerT UniWorX IO) a
 
 -- Pattern Synonyms for convenience
 pattern CSheetR tid ssh csh shn ptn
@@ -146,9 +161,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn
 -- Menus and Favourites
 data MenuItem = MenuItem
     { menuItemLabel :: Text
-    , menuItemIcon  :: Maybe Text
+    , menuItemIcon  :: Maybe Text     -- currently from: https://fontawesome.com/icons?d=gallery
     , menuItemRoute :: Route UniWorX
     , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
+    , menuItemModal :: Bool
     }
 
 menuItemAccessCallback :: MenuItem -> Handler Bool
@@ -173,7 +189,7 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage UniWorX FormMessage where
-    renderMessage _ _ = defaultFormMessage
+    renderMessage _ _  = germanFormMessage -- TODO
 
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage foundation ls TermIdentifier{..} = case season of
@@ -182,10 +198,9 @@ instance RenderMessage UniWorX TermIdentifier where
     where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX StudyFieldType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldPrimary -> MsgFieldPrimary
-    FieldSecondary -> renderMessage' MsgFieldSecondary
+    FieldSecondary -> MsgFieldSecondary
-    where renderMessage' = renderMessage foundation ls
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
@@ -200,32 +215,60 @@ instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
 instance RenderMessage UniWorX SheetFileType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      SheetExercise -> renderMessage' MsgSheetExercise
+      SheetExercise -> MsgSheetExercise
-      SheetHint     -> renderMessage' MsgSheetHint
+      SheetHint     -> MsgSheetHint
-      SheetSolution -> renderMessage' MsgSheetSolution
+      SheetSolution -> MsgSheetSolution
-      SheetMarking  -> renderMessage' MsgSheetMarking
+      SheetMarking  -> MsgSheetMarking
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX CorrectorState where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      CorrectorNormal  -> renderMessage' MsgCorrectorNormal
+      CorrectorNormal  -> MsgCorrectorNormal
-      CorrectorMissing -> renderMessage' MsgCorrectorMissing
+      CorrectorMissing -> MsgCorrectorMissing
-      CorrectorExcused -> renderMessage' MsgCorrectorExcused
+      CorrectorExcused -> MsgCorrectorExcused
-    where renderMessage' = renderMessage foundation ls
 
 
 instance RenderMessage UniWorX Load where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      (Load {byTutorial=Nothing   , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p
+      (Load {byTutorial=Nothing   , byProportion=p}) -> MsgCorByProportionOnly p
-      (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p
+      (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
-      (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
+      (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
-    where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX SheetType where
+  renderMessage foundation ls = renderMessage foundation ls . \case
+      Bonus{..} -> MsgSheetTypeBonus' maxPoints
+      Normal{..} -> MsgSheetTypeNormal' maxPoints
+      Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
+      NotGraded{} -> MsgSheetTypeNotGraded'
+
+newtype MsgLanguage = MsgLanguage Lang
+  deriving (Eq, Ord, Show, Read)
+instance RenderMessage UniWorX MsgLanguage where
+  renderMessage foundation ls (MsgLanguage lang)
+    | lang == "de-DE" = mr MsgGermanGermany
+    | "de" `isPrefixOf` lang = mr MsgGerman
+    where
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX NotificationTrigger where
+  renderMessage foundation ls = renderMessage foundation ls . \case
+    NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
+    NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
+    NTSheetActive -> MsgNotificationTriggerSheetActive
+    NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
+    NTSheetInactive -> MsgNotificationTriggerSheetInactive 
+    NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned
 
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
 
+instance RenderMessage UniWorX MessageClass where
+  renderMessage f ls = renderMessage f ls . \case
+    Error -> MsgMessageError
+    Warning -> MsgMessageWarning
+    Info -> MsgMessageInfo
+    Success -> MsgMessageSuccess
+
 
 data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
@@ -242,6 +285,23 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
 appTZ :: TZ
 appTZ = $(includeSystemTZ "Europe/Berlin")
 
+appLanguages :: NonEmpty Lang
+appLanguages = "de-DE" :| []
+
+appLanguagesOpts :: ( MonadHandler m
+                    , HandlerSite m ~ UniWorX
+                    ) => m (OptionList Lang)
+-- ^ Authoritive list of supported Languages
+appLanguagesOpts = do
+  mr <- getsYesod renderMessage
+  let mkOption l = Option
+        { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l)
+        , optionInternalValue = l
+        , optionExternalValue = l
+        }
+      langOptions = map mkOption $ toList appLanguages
+  return $ mkOptionList langOptions
+
 
 -- Access Control
 data AccessPredicate
@@ -389,6 +449,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
              && NTop courseRegisterTo   >= cTime
         return Authorized
 
+      MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
+        smId <- decrypt cID
+        SystemMessage{..} <- MaybeT $ get smId
+        cTime <- (NTop . Just) <$> liftIO getCurrentTime
+        guard $ NTop systemMessageFrom <= cTime
+             && NTop systemMessageTo   >= cTime
+        return Authorized
+
       r -> $unsupportedAuthPredicate "time" r
    )
   ,("registered", APDB $ \route _ -> case route of
@@ -436,6 +504,31 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          return Authorized
        r -> $unsupportedAuthPredicate "rated" r
    )
+  ,("user-submissions", APDB $ \route _ -> case route of
+       CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
+         Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+         Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+         guard $ sheetSubmissionMode == UserSubmissions
+         return Authorized
+       r -> $unsupportedAuthPredicate "user-submissions" r
+   )
+  ,("corrector-submissions", APDB $ \route _ -> case route of
+       CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
+         Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+         Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+         guard $ sheetSubmissionMode == CorrectorSubmissions
+         return Authorized
+       r -> $unsupportedAuthPredicate "corrector-submissions" r
+   )
+  ,("authentication", APDB $ \route _ -> case route of
+       MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
+         smId <- decrypt cID
+         SystemMessage{..} <- MaybeT $ get smId
+         isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
+         guard $ not systemMessageAuthenticatedOnly || isAuthenticated
+         return Authorized      
+       r -> $unsupportedAuthPredicate "authentication" r
+   )
   ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
   ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
   ]
@@ -454,14 +547,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK
     attrsAND = map splitAND $ Set.toList $ routeAttrs r
     splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
 
-evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
+evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
-evalAccessDB r w = case route2ap r of
+evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
   (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
   (APHandler p) -> lift $ p r w
   (APDB      p) -> p r w
 
-evalAccess :: Route UniWorX -> Bool -> Handler AuthResult
+evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
-evalAccess r w = case route2ap r of
+evalAccess r w = liftHandlerT $ case route2ap r of
   (APPure    p) -> runReader (p r w) <$> getMsgRenderer
   (APHandler p) -> p r w
   (APDB      p) -> runDB $ p r w
@@ -537,6 +630,8 @@ instance Yesod UniWorX where
     defaultLayout widget = do
         master <- getYesod
         let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
+
+        applySystemMessages
         mmsgs  <- getMessages
 
         mcurrentRoute <- getCurrentRoute
@@ -549,7 +644,7 @@ instance Yesod UniWorX where
 
         let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
 
-        menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
+        menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
 
         isAuth <- isJust <$> maybeAuthId
 
@@ -572,7 +667,7 @@ instance Yesod UniWorX where
 
         let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
             highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
-                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes
+                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
                             highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
                         in \r -> Just r == highR
             favouriteTerms :: [TermIdentifier]
@@ -604,7 +699,7 @@ instance Yesod UniWorX where
             isPageActionPrime (PageActionSecondary _) = True
             isPageActionPrime _ = False
             hasPageActions :: Bool
-            hasPageActions = any isPageActionPrime menuTypes
+            hasPageActions = any (isPageActionPrime . fst) menuTypes
 
         pc <- widgetToPageContent $ do
             addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
@@ -665,11 +760,37 @@ instance Yesod UniWorX where
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
-    shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
+    shouldLog _ _ _ = error "Must use shouldLogIO"
+    shouldLogIO app _source level = do
+      LogSettings{..} <- readTVarIO $ appLogSettings app
+      return $ logAll || level >= logMinimumLevel
 
     makeLogger = return . appLogger
 
 
+applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
+applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
+  where
+    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
+      cID <- encrypt smId
+      let sessionKey = "sm-" <> tshow (ciphertext cID)
+      assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
+      assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ()))
+      setSessionJson sessionKey ()
+      (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
+      let
+        (summary, content) = case smTrans of
+          Nothing -> (systemMessageSummary, systemMessageContent)
+          Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+      case summary of
+        Just s -> do
+          html <- withUrlRenderer [hamlet|
+              <a href=@{MessageR cID}>
+                #{s}
+            |]
+          addMessage systemMessageSeverity html
+        Nothing -> addMessage systemMessageSeverity content
+
 -- Define breadcrumbs.
 instance YesodBreadcrumbs UniWorX where
   breadcrumb (AuthR _)        = return ("Login"   , Just HomeR)
@@ -714,6 +835,12 @@ instance YesodBreadcrumbs UniWorX where
   -- Others
   breadcrumb (CorrectionsR)       = return ("Korrekturen", Just HomeR)
   breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
+  breadcrumb (MessageR _) = do
+    mayList <- (== Authorized) <$> evalAccess MessageListR False
+    return $ if
+      | mayList   -> ("Statusmeldung", Just MessageListR)
+      | otherwise -> ("Statusmeldung", Just HomeR)
+  breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR)
   breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
 
 submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
@@ -737,54 +864,70 @@ defaultLinks = -- Define the menu items of the header.
       { menuItemLabel = "Home"
       , menuItemIcon = Just "home"
       , menuItemRoute = HomeR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Impressum"
       , menuItemIcon  = Just "book"
       , menuItemRoute = VersionR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , NavbarRight $ MenuItem
-      { menuItemLabel = "Profil"
+      { menuItemLabel = "Hilfe"
+      , menuItemIcon  = Just "question"
+      , menuItemRoute = HelpR
+      , menuItemModal = True -- TODO: Does not work yet, issue #212
+      , menuItemAccessCallback' = return True
+      }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Einstellungen"
       , menuItemIcon = Just "cogs"
       , menuItemRoute = ProfileR
+      , menuItemModal = False
       , menuItemAccessCallback' = isJust <$> maybeAuthPair
       }
   , NavbarSecondary $ MenuItem
       { menuItemLabel = "Login"
       , menuItemIcon = Just "sign-in-alt"
       , menuItemRoute = AuthR LoginR
+      , menuItemModal = True -- TODO: Does not work yet, issue #212
       , menuItemAccessCallback' = isNothing <$> maybeAuthPair
       }
   , NavbarSecondary $ MenuItem
       { menuItemLabel = "Logout"
       , menuItemIcon = Just "sign-out-alt"
       , menuItemRoute = AuthR LogoutR
+      , menuItemModal = False
       , menuItemAccessCallback' = isJust <$> maybeAuthPair
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Kurse"
       , menuItemIcon = Just "calendar-alt"
       , menuItemRoute = CourseListR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Semester"
       , menuItemIcon = Just "graduation-cap"
       , menuItemRoute = TermShowR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Korrekturen"
       , menuItemIcon = Just "check"
       , menuItemRoute = CorrectionsR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Benutzer"
       , menuItemIcon = Just "users"
       , menuItemRoute = UsersR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
       }
   ]
@@ -810,14 +953,23 @@ pageActions (HomeR) =
       { menuItemLabel = "AdminDemo"
       , menuItemIcon  = Just "screwdriver"
       , menuItemRoute = AdminTestR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "System-Nachrichten"
+      , menuItemIcon = Nothing
+      , menuItemRoute = MessageListR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
 pageActions (ProfileR) =
   [ PageActionPrime $ MenuItem
-      { menuItemLabel = "Gespeicherte Daten anzeigen"
+      { menuItemLabel = "Gespeicherte Daten"
       , menuItemIcon  = Just "book"
       , menuItemRoute = ProfileDataR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -826,6 +978,7 @@ pageActions TermShowR =
       { menuItemLabel = "Neues Semester anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = TermEditR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -834,12 +987,14 @@ pageActions (TermCourseListR tid) =
       { menuItemLabel = "Neuen Kurs anlegen"
       , menuItemIcon  = Just "book"
       , menuItemRoute = CourseNewR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Semster editieren"
       , menuItemIcon  = Nothing
       , menuItemRoute = TermEditExistR tid
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -848,6 +1003,7 @@ pageActions (CourseListR) =
       { menuItemLabel = "Neuen Kurs anlegen"
       , menuItemIcon  = Just "book"
       , menuItemRoute = CourseNewR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -856,6 +1012,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       { menuItemLabel = "Übungsblätter"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetListR
+      , menuItemModal = False
       , menuItemAccessCallback' = do --TODO always show for lecturer
           let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
           muid <- maybeAuthId
@@ -872,24 +1029,28 @@ pageActions (CourseR tid ssh csh CShowR) =
       { menuItemLabel = "Abgaben"
       , menuItemIcon = Nothing
       , menuItemRoute = CourseR tid ssh csh CCorrectionsR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Neues Übungsblatt anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetNewR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionSecondary $ MenuItem
       { menuItemLabel = "Kurs editieren"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh CEditR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionSecondary $ MenuItem
       { menuItemLabel = "Neuen Kurs klonen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -898,6 +1059,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
       { menuItemLabel = "Neues Übungsblatt anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetNewR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -906,6 +1068,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       { menuItemLabel = "Abgabe anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
+      , menuItemModal = True
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
           submissions <- lift $ submissionList tid csh shn uid
@@ -916,6 +1079,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       { menuItemLabel = "Abgabe ansehen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
+      , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
           submissions <- lift $ submissionList tid csh shn uid
@@ -926,18 +1090,21 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       { menuItemLabel = "Korrektoren"
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SCorrR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Abgaben"
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SSubsR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Blatt Editieren"
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SEditR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -946,6 +1113,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
       { menuItemLabel = "Korrektoren"
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SCorrR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -954,6 +1122,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       { menuItemLabel = "Korrektur"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -962,12 +1131,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
       { menuItemLabel = "Abgaben"
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SSubsR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , PageActionSecondary $ MenuItem
       { menuItemLabel = "Edit " <> (CI.original shn)
       , menuItemIcon = Nothing
       , menuItemRoute = CSheetR tid ssh csh shn SEditR
+      , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
@@ -976,8 +1147,51 @@ pageActions (CorrectionsR) =
       { menuItemLabel = "Korrekturen hochladen"
       , menuItemIcon = Nothing
       , menuItemRoute = CorrectionsUploadR
+      , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben erstellen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsCreateR
+      , menuItemModal = True
+      , menuItemAccessCallback' = runDB $ do
+          uid <- liftHandlerT requireAuthId
+          [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
+            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            return E.countRows
+          return $ (count :: Int) /= 0
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrekturen eintragen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsGradeR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CorrectionsGradeR) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrekturen hochladen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsUploadR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben erstellen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsCreateR
+      , menuItemModal = True
+      , menuItemAccessCallback' = runDB $ do
+          uid <- liftHandlerT requireAuthId
+          [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
+            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            return E.countRows
+          return $ (count :: Int) /= 0
+      }
   ]
 pageActions _ = []
 
@@ -998,6 +1212,8 @@ pageHeading (AdminUserR _)
   = Just $ [whamlet|User Display for Admin|]
 pageHeading (VersionR)
   = Just $ i18nHeading MsgImpressumHeading
+pageHeading (HelpR)
+  = Just $ i18nHeading MsgHelpRequest
 
 pageHeading ProfileR
   = Just $ i18nHeading MsgProfileHeading
@@ -1069,6 +1285,14 @@ pageHeading CorrectionsR
   = Just $ i18nHeading MsgCorrectionsTitle
 pageHeading CorrectionsUploadR
   = Just $ i18nHeading MsgCorrUpload
+pageHeading CorrectionsCreateR
+  = Just $ i18nHeading MsgCorrCreate
+pageHeading CorrectionsGradeR
+  = Just $ i18nHeading MsgCorrGrade
+pageHeading (MessageR _)
+  = Just $ i18nHeading MsgSystemMessageHeading
+pageHeading MessageListR
+  = Just $ i18nHeading MsgSystemMessageListHeading
 
 -- TODO: add headings for more single course- and single term-pages
 pageHeading _
@@ -1223,12 +1447,14 @@ instance YesodAuth UniWorX where
 
           let
             newUser = User
-              { userMaxFavourites  = userDefaultMaxFavourites
+              { userMaxFavourites        = userDefaultMaxFavourites
-              , userTheme          = userDefaultTheme
+              , userTheme                = userDefaultTheme
-              , userDateTimeFormat = userDefaultDateTimeFormat
+              , userDateTimeFormat       = userDefaultDateTimeFormat
-              , userDateFormat     = userDefaultDateFormat
+              , userDateFormat           = userDefaultDateFormat
-              , userTimeFormat     = userDefaultTimeFormat
+              , userTimeFormat           = userDefaultTimeFormat
-              , userDownloadFiles  = userDefaultDownloadFiles
+              , userDownloadFiles        = userDefaultDownloadFiles
+              , userNotificationSettings = def
+              , userMailLanguages        = def
               , ..
               }
             userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer
@@ -1271,6 +1497,8 @@ instance YesodAuth UniWorX where
 
     authHttpManager = getHttpManager
 
+    renderAuthMessage _ _ = Auth.germanMessage -- TODO
+
 instance YesodAuthPersist UniWorX
 
 -- Useful when writing code that is re-usable outside of the Handler context.
@@ -1283,6 +1511,25 @@ unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
 
+instance YesodMail UniWorX where
+  defaultFromAddress = getsYesod $ appMailFrom . appSettings
+  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+  mailVerp = getsYesod $ appMailVerp . appSettings
+  mailDateTZ = return appTZ
+  mailSmtp act = do
+    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
+    withResource pool act
+  mailT ctx mail = defMailT ctx $ do 
+    setMailObjectId
+    setDateCurrent
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  
+    ret <- mail
+  
+    setMailSmtpData
+    return ret
+
+
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey
   cryptoIDKey f = getsYesod appCryptoIDKey >>= f

src/Handler/Admin.hs

@@ -7,11 +7,13 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Handler.Admin where
 
 import Import
 import Handler.Utils
+import Jobs
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -20,6 +22,8 @@ import Handler.Utils
 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
+import Database.Persist.Sql (fromSqlKey)
+
 -- import Colonnade hiding (fromMaybe)
 -- import Yesod.Colonnade
 
@@ -41,22 +45,54 @@ instance Button UniWorX CreateButton where
   cssClass CreateInf  = 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 CreateButton)
   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 $ do
+    -- setTitle "Uni2work Admin Testpage"
+    $(widgetFile "adminTest")
 
 
 getAdminUserR :: CryptoUUIDUser -> Handler Html

src/Handler/Corrections.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -21,11 +20,14 @@ module Handler.Corrections where
 import Import
 -- import System.FilePath (takeFileName)
 
+import Jobs
 import Handler.Utils
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 -- import Handler.Utils.Zip
 
+import Utils.Lens
+
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
@@ -33,6 +35,8 @@ import qualified Data.Map as Map
 
 import qualified Data.Text as Text
 
+import Data.Semigroup (Sum(..))
+
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
@@ -46,7 +50,6 @@ import Colonnade hiding (fromMaybe, singleton, bool)
 import qualified Database.Esqueleto as E
 -- import qualified Database.Esqueleto.Internal.Sql as E
 
-import Control.Lens
 -- import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 -- import Network.Mime
@@ -60,6 +63,20 @@ import Database.Persist.Sql (updateWhereCount)
 
 import Data.List (genericLength)
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Control.Monad.Trans.RWS (RWST)
+
+import Control.Monad.Trans.State (State, StateT(..), runState)
+import qualified Control.Monad.State.Class as State
+
+import Data.Foldable (foldrM)
+import Data.Traversable (for)
+
 
 
 type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
@@ -75,8 +92,11 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
 sheetIs :: Key Sheet -> CorrectionsWhere
 sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
 
+submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
+submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
 
-type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
+
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
 
 colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
@@ -128,13 +148,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
   tid = course ^. _3
   ssh = course ^. _4
   link cid = CourseR tid ssh csh $ CUserR cid
-  cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
+  cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
-    anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
+    anchorCellM (link <$> encrypt userId) $ case mPseudo of
+      Nothing -> nameWidget userDisplayName userSurname
+      Just p  -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
   in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
 colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
-  cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
+  cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
   in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
   
 colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@@ -156,13 +178,36 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
   maybe mempty timeCell submissionRatingTime
 
+colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+    lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
+      cell [whamlet|#{review pseudonymText pseudo}|]
+  in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+
+colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
+colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
+
+colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
+colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone) $ formCell
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
+      NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
+      _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
+  )
+
+colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
+colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
 
 
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
             
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
-makeCorrectionsTable whereClause colChoices psValidator = do
+makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
       dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
         E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
@@ -176,57 +221,64 @@ makeCorrectionsTable whereClause colChoices psValidator = do
                     )
         return (submission, sheet, crse, corrector)
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
-      dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
+      dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
-        submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+        submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
+          E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
+           E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
           E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
           E.orderBy [E.asc $ user E.^. UserId]
-          return user
+          return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
-          submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
+          submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors
-        return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
+        dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
   dbTable psValidator $ DBTable
     { dbtSQLQuery
-    , dbtColonnade = colChoices
+    , dbtColonnade
     , dbtProj
-    , dbtSorting   = [ ( "term"
+    , dbtSorting   = Map.fromList
-                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
+      [ ( "term"
-                       )
+        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
-                     , ( "course"
+        )
-                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
+      , ( "course"
-                       )
+        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
-                     , ( "sheet"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+      , ( "sheet"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
-                     , ( "corrector"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
+      , ( "corrector"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
-                     , ( "rating"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
+      , ( "rating"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
-                     ]
+        )
-    , dbtFilter    = [ ( "term"
+      , ( "ratingtime"
-                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
-                           | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+        )
-                           | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+      ]
-                       )
+    , dbtFilter    = Map.fromList
-                     , ( "course"
+      [ ( "term"
-                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
+        , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
-                           | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
+            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
-                           | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
+            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
-                       )
+        )
-                     , ( "sheet"
+      , ( "course"
-                       , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
+        , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
-                           | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
+            | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
-                           | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
+            | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
-                       )
+        )
-                     , ( "corrector"
+      , ( "sheet"
-                       , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
+        , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
-                           | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
+            | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
-                           | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
+            | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
-                                          E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+        )
-                       )
+      , ( "corrector"
-                     ]
+        , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
+            | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
+            | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
+                           E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+        )
+      ]
     , dbtStyle     = def
     , dbtIdent     = "corrections" :: Text
     }
@@ -248,12 +300,12 @@ data ActionCorrectionsData = CorrDownloadData
                            | CorrSetCorrectorData (Maybe UserId)
                            | CorrAutoSetCorrectorData SheetId
 
-correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
+correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
     ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
-    (actionRes, action) <- multiAction actions
+    (actionRes, action) <- multiAction actions Nothing
     return ((,) <$> actionRes <*> selectionRes, table <> action)
 
   Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
@@ -323,16 +375,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
     $(widgetFile "corrections")
 
 
-type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
+type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
   
 downloadAction :: ActionCorrections'
 downloadAction = ( CorrDownload
-                 , return (pure CorrDownloadData, Nothing)
+                 , pure CorrDownloadData
                  )
 
 assignAction :: Either CourseId SheetId -> ActionCorrections'
 assignAction selId = ( CorrSetCorrector
-                     , over (mapped._2) Just $ do
+                     , wFormToAForm $ do
                          correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
                            E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
                            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@@ -346,14 +398,13 @@ assignAction selId = ( CorrSetCorrector
 
                          correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
 
-                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
+                         cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
-                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
+                         fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
-                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
                      )
 
 autoAssignAction :: SheetId -> ActionCorrections'
 autoAssignAction shid = ( CorrAutoSetCorrector
-                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
+                        , pure $ CorrAutoSetCorrectorData shid
                         )
 
 getCorrectionsR, postCorrectionsR :: Handler TypedContent
@@ -367,6 +418,7 @@ postCorrectionsR = do
         , colTerm
         , colCourse
         , colSheet
+        , colPseudonyms
         , colSubmissionLink
         , colAssigned
         , colRating
@@ -449,9 +501,13 @@ postCorrectionR tid ssh csh shn cid = do
   case results of
     [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+          pointsForm = case sheetType of
+            NotGraded  -> pure Nothing
+            _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints)
 
-      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
+      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
-        <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
+        <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
+        <*> pointsForm
         <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
         <* submitButton
 
@@ -462,12 +518,12 @@ postCorrectionR tid ssh csh shn cid = do
       case corrResult of
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-        FormSuccess (ratingPoints, ratingComment) -> do
+        FormSuccess (rated, ratingPoints, ratingComment) -> do
-          runDB $ do
+          runDBJobs $ do
             uid <- liftHandlerT requireAuthId
             now <- liftIO getCurrentTime
 
-            let rated = isJust $ void ratingPoints <|> void ratingComment
+            Submission{submissionRatingTime} <- getJust sub
           
             update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
 -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
@@ -478,6 +534,11 @@ postCorrectionR tid ssh csh shn cid = do
                        ]
 
             addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+
+            when (rated && isNothing submissionRatingTime) $ do
+              $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+              queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
+
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
@@ -486,7 +547,7 @@ postCorrectionR tid ssh csh shn cid = do
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
-          runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
           addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -521,7 +582,7 @@ postCorrectionsUploadR = do
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
-      subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
+      subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
       if
         | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do
@@ -532,3 +593,190 @@ postCorrectionsUploadR = do
 
   defaultLayout $ do
     $(widgetFile "corrections-upload")
+
+getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
+getCorrectionsCreateR = postCorrectionsCreateR
+postCorrectionsCreateR = do
+  uid <- requireAuthId
+  let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+        E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+        E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
+             E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+        E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
+        return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
+      mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
+      mkOptList opts = do
+        opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
+        MsgRenderer mr <- getMsgRenderer
+        return . mkOptionList $ do
+          (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
+          let tid' = mr $ ShortTermIdentifier (unTermKey tid)
+          return Option
+            { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
+            , optionInternalValue = sid
+            , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
+            }
+  ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
+    <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
+    <*> areq (checkMMap textToList textFromList textareaField) (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing
+    <* submitButton
+
+  case pseudonymRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess (sid, pss) -> do
+      now <- liftIO getCurrentTime
+      runDB $ do
+        Sheet{..} <- get404 sid
+        (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
+        forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText
+        now <- liftIO getCurrentTime
+        let
+          sps' :: [[SheetPseudonym]]
+          duplicate :: Set Pseudonym
+          ( sps'
+            , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
+            ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
+                  known <- State.gets $ Map.member sheetPseudonymPseudonym
+                  State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
+                  return $ bool (p :) id known ps
+          submission = Submission
+            { submissionSheet = sid
+            , submissionRatingPoints = Nothing
+            , submissionRatingComment = Nothing
+            , submissionRatingBy = Just uid
+            , submissionRatingAssigned = Just now
+            , submissionRatingTime = Nothing
+            }
+        when (not $ null duplicate)
+          $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
+        existingSubUsers <- E.select . E.from $ \submissionUser -> do
+          E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
+          return submissionUser
+        when (not $ null existingSubUsers) $ do
+          (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
+          $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
+        let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
+        forM_ sps'' $ \spGroup
+          -> let
+               sheetGroupDesc = Text.intercalate ", " $ map (review pseudonymText . sheetPseudonymPseudonym) spGroup
+              in case sheetGrouping of
+          Arbitrary maxSize
+            | genericLength sps > maxSize
+              -> addMessageI Error $ MsgSheetGroupTooLarge sheetGroupDesc
+            | otherwise
+              -> do
+                subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }
+          RegisteredGroups -> do
+            groups <- E.select . E.from $ \submissionGroup -> do
+              E.where_ . E.exists . E.from $ \submissionGroupUser ->
+                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
+              return $ submissionGroup E.^. SubmissionGroupId
+            case (groups :: [E.Value SubmissionGroupId]) of
+              [x] -> do
+                subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }
+              [] -> do
+                subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }               
+                addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+              _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+          NoGroups
+            | [SheetPseudonym{sheetPseudonymUser}] <- spGroup
+              -> do
+                subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
+                insert_ SubmissionUser
+                  { submissionUserUser = sheetPseudonymUser
+                  , submissionUserSubmission = subId
+                  }
+            | otherwise -> do
+                subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }               
+                addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+      redirect CorrectionsGradeR
+                
+  
+  defaultLayout $ do
+    $(widgetFile "corrections-create")
+  where
+    partition :: [[Either a b]] -> ([[b]], [a])
+    partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) 
+    
+    textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
+    textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
+      = let
+          invalid :: [Text]
+          valid :: [[Pseudonym]]
+          (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws
+        in case invalid of
+             (i:_) -> return . Left $ MsgInvalidPseudonym i
+             []    -> return $ Right valid
+    textFromList :: [[Pseudonym]] -> Textarea
+    textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
+
+getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
+getCorrectionsGradeR = postCorrectionsGradeR
+postCorrectionsGradeR = do
+  uid <- requireAuthId
+  let whereClause = ratedBy uid
+      displayColumns = mconcat -- should match getSSubsR for consistent UX
+        [ dbRow
+        , colTerm
+        , colCourse
+        , colSheet
+        , colPseudonyms
+        , colSubmissionLink
+        , colRated
+        , colRatedField
+        , colPointsField
+        , colCommentField
+        ] -- Continue here
+      psValidator = def
+        & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
+      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
+  
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
+    cID <- encrypt subId
+    void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
+    return i
+  (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
+
+  case tableRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess resMap -> do
+      now <- liftIO getCurrentTime
+      subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
+        s@Submission{..} <- get404 subId
+        if
+          | submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
+            -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
+                                          , SubmissionRatingComment =. mComment
+                                          , SubmissionRatingBy =. Just uid
+                                          , SubmissionRatingTime =. now <$ guard rated
+                                          ]
+          | otherwise -> return $ Nothing
+      subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
+      unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
+
+  defaultLayout $ do
+    $(widgetFile "corrections-grade")

src/Handler/Course.hs

@@ -15,7 +15,7 @@
 
 module Handler.Course where
 
-import Import
+import Import hiding (catMaybes)
 
 import Control.Lens
 import Utils.Lens
@@ -33,6 +33,9 @@ import Data.Maybe
 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
 
@@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do
     (_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
@@ -325,59 +336,55 @@ getCourseNewR = do
             <*> iopt ciField      "ssh"
             <*> iopt ciField      "csh"
   let noTemplateAction = courseEditHandler True Nothing
-  case params of
+  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
+                        noTemplateAction
-    FormSuccess (mbTid,mbSsh,mbCsh) ->
+    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
-      getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
+      uid <- requireAuthId
-
+      oldCourses <- runDB $ do
-getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
+        E.select $ E.from $ \course -> do
-getCourseNewTemplateR mbTid mbSsh mbCsh = do
+          whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
-  uid <- requireAuthId
+          whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
-  oldCourses <- runDB $ do
+          whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
-    E.select $ E.from $ \course -> do
+          let lecturersCourse =
-      whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+                E.exists $ E.from $ \lecturer -> do
-      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
-      whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
+                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-      let lecturersCourse =
+          let lecturersSchool =
-            E.exists $ E.from $ \lecturer -> do
+                E.exists $ E.from $ \user -> do
-              E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
+                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
-                  E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
-      let lecturersSchool =
+          let courseCreated c =
-            E.exists $ E.from $ \user -> do
+                E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
-              E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                  E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
-                  E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+                  return $ E.min_ $ edit E.^. CourseEditTime
-      let courseCreated c =
+          E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
-            E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+                    , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
-              E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+                    , E.desc $ courseCreated course]                                     -- most recent created course
-              return $ E.min_ $ edit E.^. CourseEditTime
+          E.limit 1
-      E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
+          return course
-                , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
+      template <- case listToMaybe oldCourses of
-                , E.desc $ courseCreated course]                                     -- most recent created course
+        (Just oldTemplate) ->
-      E.limit 1
+            let newTemplate = (courseToForm oldTemplate) in
-      return course
+            return $ Just $ newTemplate
-  template <- case listToMaybe oldCourses of
+                { cfCourseId   = Nothing
-    (Just oldTemplate) ->
+                , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
-        let newTemplate = (courseToForm oldTemplate) in
+                , cfRegFrom    = Nothing
-        return $ Just $ newTemplate
+                , cfRegTo      = Nothing
-            { cfCourseId   = Nothing
+                , cfDeRegUntil = Nothing
-            , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
+                }
-            , cfRegFrom    = Nothing
+        Nothing -> do
-            , cfRegTo      = Nothing
+            (tidOk,sshOk,cshOk) <- runDB $ (,,)
-            , cfDeRegUntil = Nothing
+                <$> ifMaybeM mbTid True existsKey
-            }
+                <*> ifMaybeM mbSsh True existsKey
-    Nothing -> do
+                <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
-        (tidOk,sshOk,cshOk) <- runDB $ (,,)
+            unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
-            <$> ifMaybeM mbTid True existsKey
+            unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
-            <*> ifMaybeM mbSsh True existsKey
+            unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
-            <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+            when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
-        unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+            return Nothing
-        unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+      courseEditHandler True template
-        unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
-        when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
-        return Nothing
-  courseEditHandler True template
 
 postCourseNewR :: Handler Html
 postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.

src/Handler/Home.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
@@ -16,7 +18,14 @@ import Handler.Utils
 
 import qualified Data.Map as Map
 
+import qualified Data.Text as Text
+import Data.Text.Encoding (decodeUtf8')
 import Data.Time hiding (formatTime)
+import Data.Universe
+import Data.Universe.Helpers
+
+import Network.Wai (requestHeaderReferer)
+
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
 
@@ -27,6 +36,8 @@ import Data.Time hiding (formatTime)
 -- import Yesod.Colonnade
 import qualified Database.Esqueleto as E
 
+import Jobs
+
 -- import Text.Shakespeare.Text
 
 import Development.GitRev
@@ -106,10 +117,10 @@ homeAnonymous = do
     , dbtStyle     = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  let features = $(widgetFile "featureList")
+  -- let features = $(widgetFile "featureList")
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout $ do
-    $(widgetFile "dsgvDisclaimer")
+    -- $(widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
 
 homeUser :: Key User -> Handler Html
@@ -117,10 +128,10 @@ homeUser uid = do
   cTime <- liftIO getCurrentTime
   let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
 
-      tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
+      tableData :: E.LeftOuterJoin
-                   --                         (E.SqlExpr (Entity Course           )))
+                        (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
-                   --                         (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.SqlQuery ( E.SqlExpr (E.Value (Key Term))
                                 , E.SqlExpr (E.Value SchoolId)
                                 , E.SqlExpr (E.Value CourseShorthand)
                                 , E.SqlExpr (E.Value SheetName)
@@ -207,11 +218,11 @@ homeUser uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
   defaultLayout $ do
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")
-    $(widgetFile "dsgvDisclaimer")
+    -- $(widgetFile "dsgvDisclaimer")
 
 
 getVersionR :: Handler TypedContent
@@ -224,3 +235,79 @@ getVersionR = selectRep $ do
       $(widgetFile "versionHistory")
     provideRep $
       return ($gitDescribe :: Text)
+
+
+
+
+data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+instance Universe HelpIdentOptions where universe = universeDef
+instance Finite HelpIdentOptions
+
+instance PathPiece HelpIdentOptions where
+  toPathPiece   = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX HelpIdentOptions where
+  renderMessage foundation ls = renderMessage foundation ls . \case 
+    HIUser      -> MsgHelpUser 
+    HIEmail     -> MsgHelpEMail
+    HIAnonymous -> MsgHelpAnonymous
+
+data HelpForm = HelpForm
+  { hfReferer:: Maybe Text
+  , hfUserId :: Either (Maybe Email) UserId
+  , hfRequest:: Text
+  }
+
+helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm
+helpForm mReferer mUid = HelpForm
+    <$> maybe (pure Nothing) (fmap Just . aforced textField  (fslI MsgHelpProblemPage)) mReferer
+    <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
+    <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
+    <*  submitButton
+  where
+    identActions :: Map _ (AForm _ (Either (Maybe Email) UserId))
+    identActions = Map.fromList $ case mUid of 
+      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+      Nothing    -> defaultActions 
+    
+    defaultActions =
+      [ (HIEmail, Left . Just <$> apreq emailField (fslI MsgEMail) Nothing)
+      , (HIAnonymous, pure $ Left Nothing)
+      ]
+
+getHelpR :: Handler Html
+getHelpR = postHelpR
+
+postHelpR :: Handler Html
+postHelpR = do
+  mUid <- maybeAuthId
+  mRefererBS <- requestHeaderReferer <$> waiRequest
+  let mReferer = maybeRight . decodeUtf8' =<< mRefererBS
+
+  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
+
+  case res of
+    FormSuccess (HelpForm{..}) -> do
+      now <- liftIO getCurrentTime
+      queueJob' $ JobHelpRequest { jSender      = hfUserId
+                                  , jHelpRequest = hfRequest
+                                  , jRequestTime = now
+                                  , jReferer     = hfReferer }
+      -- redirect $ HelpR
+      addMessageI Success MsgHelpSent
+      return ()
+      {-selectRep $ do
+          provideJson ()
+          provideRep (redirect $ HelpR :: Handler Html) -}
+    FormMissing -> return ()
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
+
+  defaultLayout $ do
+    setTitle "Hilfe" -- TODO: International
+    $(widgetFile "help")
+
+

src/Handler/Profile.hs

@@ -24,6 +24,8 @@ import Utils.Lens
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
 import qualified Data.Map as Map
+import Data.Map ((!))
+import qualified Data.Set as Set
 -- import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
@@ -37,6 +39,7 @@ data SettingsForm = SettingsForm
       , stgDate          :: DateTimeFormat
       , stgTime          :: DateTimeFormat
       , stgDownloadFiles :: Bool
+      , stgNotificationSettings :: NotificationSettings
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
+      <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
       <*  submitButton
     return (result, widget) -- no validation required here
+  where
+    nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
+      areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
+    nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
+    nsFieldView (res, fvInput) = do
+      mr <- getMessageRender
+      let fvLabel = toHtml $ mr MsgNotificationSettings
+          fvTooltip = mempty
+          fvRequired = True
+          fvErrors
+            | FormFailure (err:_) <- res = Just $ toHtml err
+            | otherwise = Nothing
+      fvId <- newIdent
+      return (res, pure FieldView{..})
+    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
 
-getProfileR :: Handler Html
+getProfileR, postProfileR :: Handler Html
-getProfileR = do
+getProfileR = postProfileR
+postProfileR = do
   (uid, User{..}) <- requireAuthPair
   let settingsTemplate = Just $ SettingsForm
         { stgMaxFavourties = userMaxFavourites
@@ -68,6 +88,7 @@ getProfileR = do
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
         , stgDownloadFiles = userDownloadFiles
+        , stgNotificationSettings = userNotificationSettings
         }
   ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
   case res of
@@ -79,6 +100,7 @@ getProfileR = do
                       , UserDateFormat     =. stgDate
                       , UserTimeFormat     =. stgTime
                       , UserDownloadFiles  =. stgDownloadFiles
+                      , UserNotificationSettings =. stgNotificationSettings
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size
@@ -93,52 +115,11 @@ getProfileR = do
     (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
     _ -> return ()
 
-
+  let formText  = Nothing :: Maybe UniWorXMessage
-  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
+      actionUrl = ProfileR      
-            (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
-      actionUrl = ProfileR
-      settingsForm = $(widgetFile "formPageI18n")
   defaultLayout $ do
     setTitle . toHtml $ userIdent <> "'s User page"
-    $(widgetFile "profile")
+    $(widgetFile "formPageI18n")    
-    $(widgetFile "dsgvDisclaimer")
-
-postProfileR :: Handler Html
-postProfileR = do
-  -- TODO
-  getProfileR
 
 postProfileDataR  :: Handler Html
 postProfileDataR = do
@@ -146,17 +127,69 @@ postProfileDataR = do
   case btnResult of
     (FormSuccess BtnDelete) -> do
       (uid, User{..}) <- requireAuthPair
-      addMessage Warning "Delete-Knopf gedrückt"
+      clearCreds False -- Logout-User
-      addMessage Error "Löschen der Daten wurde noch nicht implementiert."
+      ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
-      -- first determine all submission that solely depend on this user:
+      -- addMessageIHamlet
-      -- SubmissionGroup / SubmissionGroupUser
+      $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-      -- Submission / SubmissionUser
+      -- addMessageI Success $ MsgDeleteUser deletedSubmissions
-      -- runDB $ deleteCascade uid
+      -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
+      defaultLayout $ do
+        $(widgetFile "deletedUser")
+
     (FormSuccess BtnAbort ) -> do
       addMessageI Info MsgAborted
       redirect ProfileDataR
-    _other -> return ()
+    _other -> getProfileDataR
-  getProfileDataR
+
+
+
+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 -> do
+          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 -> do
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+              E.&&.  subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
+      E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+              E.&&.  subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
+
+
+
 
 
 
@@ -164,6 +197,39 @@ getProfileDataR  :: Handler Html
 getProfileDataR = do
   (uid, User{..}) <- requireAuthPair
   --   mr <- getMessageRender
+  (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)
+    )
   -- Tabelle mit eigenen Kursen
   (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
   -- Tabelle mit allen Teilnehmer: Kurs (link), Datum

src/Handler/Sheet.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -14,6 +13,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Handler.Sheet where
 
@@ -48,6 +48,8 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 -- import qualified Data.List as List
 
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE)
+
 import Network.Mime
 
 import Data.Set (Set)
@@ -57,11 +59,17 @@ import qualified Data.Map as Map
 import Data.Map (Map, (!), (!?))
 import qualified Data.Map as Map
 
-import Data.Monoid (Sum(..))
+import Data.Monoid (Sum(..), Any(..))
 
 import Control.Lens
 -- import Utils.Lens
 
+import qualified Data.Text as Text
+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) =
@@ -77,11 +85,11 @@ data SheetForm = SheetForm
       { sfName         :: SheetName
       , sfDescription  :: Maybe Html
       , sfType         :: SheetType
-      , sfGrouping     :: SheetGroup
+      , 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 +97,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!
       }
 
@@ -111,8 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
       <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> 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 +128,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 +140,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
@@ -149,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       ] ]
 
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getSheetListR tid ssh csh = do
+getSheetListR tid ssh csh = do 
   muid <- maybeAuthId
   Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
   let
@@ -244,6 +254,21 @@ getSheetListR tid ssh csh = do
     $(widgetFile "sheetList")
     $(widgetFile "widgets/sheetTypeSummary")
 
+data ButtonGeneratePseudonym = BtnGenerate
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+instance Universe ButtonGeneratePseudonym
+instance Finite ButtonGeneratePseudonym
+
+$(return [])
+
+instance PathPiece ButtonGeneratePseudonym where
+  toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel])
+  fromPathPiece = finiteFromPathPiece
+
+instance Button UniWorX ButtonGeneratePseudonym where
+  label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
+  cssClass BtnGenerate = BCDefault
+
 -- Show single sheet
 getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSShowR tid ssh csh shn = do
@@ -273,14 +298,14 @@ getSShowR tid ssh csh shn = do
         -- 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 "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
         , 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 "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
         ]
   let psValidator = def
         & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  ((), fileTable) <- dbTable psValidator $ DBTable
+  (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
@@ -288,16 +313,17 @@ getSShowR tid ssh csh shn = do
     , dbtStyle = def
     , dbtFilter = Map.empty
     , dbtIdent = "files" :: Text
-    , dbtSorting = [ ( "type"
+    , dbtSorting = Map.fromList
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
+      [ ( "type"
-                     )
+        , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
-                   , ( "path"
+        )
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
+      , ( "path"
-                     )
+        , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
-                   , ( "time"
+        )
-                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
+      , ( "time"
-                     )
+        , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
-                   ]
+        )
+      ]
     }
   (hasHints, hasSolution) <- runDB $ do
     hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
@@ -307,6 +333,12 @@ 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 . Text.unwords . map CI.original $ review pseudonymWords 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
@@ -315,6 +347,32 @@ getSShowR tid ssh csh shn = do
     solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
     $(widgetFile "sheetShow")
 
+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
+  let ps' = Text.unwords . map CI.original $ review pseudonymWords ps
+  selectRep $ do
+    provideRep $ return 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 $
@@ -361,11 +419,11 @@ getSheetNewR tid ssh csh = do
           { sfName         = stepTextCounterCI sheetName
           , sfDescription  = sheetDescription
           , sfType         = sheetType
-          , sfGrouping     = sheetGrouping
+          , sfGrouping     = sheetGrouping          
-          , sfMarkingText  = sheetMarkingText
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfSubmissionMode = sheetSubmissionMode
           , sfUploadMode   = sheetUploadMode
           , sfSheetF       = Nothing
           , sfHintFrom     = addOneWeek <$> sheetHintFrom
@@ -373,6 +431,7 @@ getSheetNewR tid ssh csh = do
           , sfSolutionFrom = addOneWeek <$> 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
@@ -395,11 +454,11 @@ getSEditR tid ssh csh shn = do
         { sfName         = sheetName
         , sfDescription  = sheetDescription
         , sfType         = sheetType
-        , sfGrouping     = sheetGrouping
+        , 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 +466,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
@@ -441,6 +501,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
               , sheetUploadMode   = sfUploadMode
+              , sheetSubmissionMode = sfSubmissionMode
               }
         mbsid <- dbAction newSheet
         case mbsid of

src/Handler/Submission.hs

@@ -20,6 +20,8 @@ module Handler.Submission where
 
 import Import hiding (joinPath)
 
+import Jobs
+
 -- import Yesod.Form.Bootstrap3  
 
 import Handler.Utils
@@ -72,7 +74,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $
     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
+                                    | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
                                     ])
       <*  submitButton
@@ -178,7 +180,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             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
+  mCID <- runDBJobs $ do
     res' <- case res of
       (FormMissing )           -> return $ FormMissing
       (FormFailure failmsgs)   -> return $ FormFailure failmsgs
@@ -215,7 +217,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
               ]
@@ -232,8 +234,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
-            (Just files, _)  -- new files
+            (Just files, _) -> -- new files
-              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+              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

src/Handler/SystemMessage.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , TemplateHaskell
+           , NamedFieldPuns
+           , RecordWildCards
+           , OverloadedStrings
+           , TypeFamilies
+           , ViewPatterns
+           , FlexibleContexts
+           , LambdaCase
+           , MultiParamTypeClasses
+  #-}
+
+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
+
+  
+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 :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype))
+    mkForm = do
+      modifyRes'@((modifyRes, _), _) <- 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 (id :: MessageClass -> MessageClass)) (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)
+              )
+          <*> combinedButtonField (universeF :: [BtnSubmitDelete])
+
+      let modifyTranss = Map.map (view $ _1._1) modifyTranss'
+
+      addTransRes'@((addTransRes, _), _) <- 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 $ \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
+
+      formResult addTransRes $ \smt -> do
+        runDB . void . insert $ smt
+        addMessageI Success MsgSystemMessageAddTranslationSuccess
+        redirect $ MessageR cID
+
+      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
+  
+      return (modifyRes', modifyTranss', addTransRes')
+
+  maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
+  forms <- traverse (const mkForm) $ () <$ guard maySubmit
+  
+  defaultLayout $ do
+    $(widgetFile "system-message")
+
+
+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
+$(return [])
+instance PathPiece ActionSystemMessage where
+  toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX ActionSystemMessage where
+  renderMessage m ls = renderMessage m ls . \case
+    SMDelete -> MsgSystemMessageDelete
+    SMActivate -> MsgSystemMessageActivate
+    SMDeactivate -> MsgSystemMessageDeactivate
+
+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 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
+      , dbRow
+      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (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 (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
+  tableForm <- dbTable psValidator $ DBTable
+    { dbtSQLQuery
+    , dbtColonnade
+    , dbtProj
+    , dbtSorting = Map.fromList
+      [ -- TODO: from, to, authenticated, severity
+      ]
+    , dbtFilter = Map.fromList
+      [
+      ]
+    , dbtStyle = def
+    , dbtIdent = "messages" :: Text
+    }
+  ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
+    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
+    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)
+    $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
+    return ((,) <$> actionRes <*> selectionRes, table <> action)
+
+  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)
+      | 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 (id :: MessageClass -> MessageClass)) (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 $ do
+    $(widgetFile "system-message-list")

src/Handler/Utils.hs

@@ -25,6 +25,7 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 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

src/Handler/Utils/DateTime.hs

@@ -11,6 +11,7 @@ module Handler.Utils.DateTime
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
+  , formatTimeMail
   , addOneWeek
   ) where
 
@@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Mail
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -58,6 +61,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
 

src/Handler/Utils/Form.hs

@@ -25,7 +25,7 @@ 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(..))
 
@@ -60,6 +60,10 @@ import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
 
+import Data.Maybe (fromJust)
+
+import Utils.Lens
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -104,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where
 
   cssClass BtnHijack = BCDefault
 
+data BtnSubmitDelete = BtnSubmit' | BtnDelete'
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance Universe BtnSubmitDelete
+instance Finite BtnSubmitDelete
+
+instance Button UniWorX BtnSubmitDelete where
+  label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
+  label BtnDelete' = [whamlet|_{MsgBtnDelete}|]
+
+  cssClass BtnSubmit' = BCPrimary
+  cssClass BtnDelete' = BCDanger
+
+$(return [])
+
+instance PathPiece BtnSubmitDelete where
+  toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
+  fromPathPiece = finiteFromPathPiece
+
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)
@@ -121,37 +144,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 --   |]
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
-    {-
-combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
-combinedButtonField btns inner csrf = do
-    buttonIdent <- newFormIdent
-    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
-    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
-    (innerRes,innerWdgt) <- inner
-    let widget = do
-          [whamlet|
-            #{csrf}
-            ^{innerWdgt}
-            <div .btn-group>
-              $forall bView <- btnViews
-                ^{fvInput bView}
-          |]
-    let result = case (accResult result, innerRes) of
-                    (FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
-                    _ -> FormFailure ["Something went wrong"] -- TODO
-    return (result,widget)
-  where
-    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
-    accResult = Foldable.foldr accResult' FormMissing
-
-    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
-    accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
-    accResult' (FormSuccess Nothing) x = x
-    accResult' FormMissing _ = FormMissing
-    accResult' (FormFailure errs) _ = FormFailure errs
-    -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
 buttonForm :: (Button UniWorX a, Show a) => Form a
@@ -165,18 +157,16 @@ buttonForm csrf = do
             $forall bView <- btnViews
               ^{fvInput bView}
           |]
-    $logDebugS "FormResult" $ tshow results
     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
-    -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one!
+    -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
-    -- TODO: Maybe change buttonField?
     accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
     accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
+    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
@@ -257,6 +247,22 @@ uploadModeField = selectFieldList
   , (MsgUploadModeUnpack  , Upload   True )
   ]
 
+submissionModeField :: Field Handler SheetSubmissionMode
+submissionModeField = selectFieldList
+  [ (MsgSheetNoSubmission, NoSubmissions)
+  , (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
+  , (MsgSheetUserSubmissions, UserSubmissions)
+  ]
+
+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)
 zipFileField doUnpack = Field{..}
@@ -321,23 +327,122 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+data SheetType' = Bonus' | Normal' | Pass' | NotGraded'
-sheetTypeAFormReq d Nothing =
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-  -- 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
 
+instance Universe SheetType'
+instance Finite SheetType'
+
+$(return [])
+
+instance PathPiece SheetType' where
+  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetType' where
+  renderMessage f ls = \case
+    Bonus' -> render MsgSheetTypeBonus
+    Normal' -> render MsgSheetTypeNormal
+    Pass' -> render MsgSheetTypePass
+    NotGraded' -> render MsgSheetTypeNotGraded
+    where
+      render = renderMessage f ls
+
+data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetGroup'
+instance Finite SheetGroup'
+
+$(return [])
+
+instance PathPiece SheetGroup' where
+  toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetGroup' where
+  renderMessage f ls = \case
+    Arbitrary' -> render MsgSheetGroupArbitrary
+    RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
+    NoGroups' -> render MsgSheetGroupNoGroups
+    where
+      render = renderMessage f ls
+
+sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
+  let
+    selOptions = Map.fromList
+      [ ( Bonus', Bonus <$> maxPointsReq )
+      , ( Normal', Normal <$> maxPointsReq )
+      , ( Pass', Pass
+          <$> maxPointsReq
+          <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
+        )
+      , ( NotGraded', pure NotGraded )
+      ]
+  (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
+    maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
+    
+    classify' :: SheetType -> SheetType'
+    classify' = \case
+      Bonus _ -> Bonus'
+      Normal _ -> Normal'
+      Pass _ _ -> Pass'
+      NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
+sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+  let
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
+    selOptions = Map.fromList
-sheetGroupAFormReq d _other = -- TODO
+      [ ( Arbitrary', Arbitrary
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
+        )
+      , ( 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
@@ -385,6 +490,11 @@ utcTimeField = Field
         (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
+
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
 fsm = bfs -- TODO: get rid of Bootstrap
@@ -449,15 +559,61 @@ 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
+  fmap (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
+  fmap (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
+  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
-  results <- sequence acts
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+  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
+      }
+    ])
+
+
+

src/Handler/Utils/Mail.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE NoImplicitPrelude
+           , NamedFieldPuns
+           , TypeFamilies
+           , FlexibleContexts
+           , ViewPatterns
+           , LambdaCase
+  #-}
+
+module Handler.Utils.Mail
+  ( addRecipientsDB
+  , userMailT
+  , addFileDB
+  ) where
+
+import Import hiding ((.=))
+
+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/Submission.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
 
 
 module Handler.Utils.Submission
@@ -25,6 +26,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Jobs
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -38,7 +40,7 @@ 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)
@@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any
+  , sinkSubmissionNotifyRating :: Any
   , sinkFilenames :: Set FilePath
   } deriving (Show, Eq, Generic, Typeable)
 
@@ -333,7 +336,7 @@ extractRatingsMsg = do
 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'.
@@ -365,7 +368,7 @@ sinkSubmission userId mExists isUpdate = do
 
     sinkSubmission' :: SubmissionId
                     -> Bool -- ^ Is this a correction
-                    -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> Sink SubmissionContent (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@@ -463,18 +466,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
+            case isUpdate of
-              False -> insert_ $ SubmissionEdit userId now submissionId
+              False -> lift . insert_ $ SubmissionEdit userId now submissionId
-              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+              True  -> do
-                        -- TODO: Should submissionRatingAssigned change here if userId changes?
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True }
+                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                -- TODO: Should submissionRatingAssigned change here if userId changes?
             tell $ 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,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do
                   update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
-          when (isUpdate && not (getAny sinkSeenRating)) $
+          if
-            update submissionId
+            | 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
@@ -529,7 +541,7 @@ 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'.
 --
@@ -543,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do
          -> RWST
               ()
               _
-              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
-              (YesodDB UniWorX)
+              (YesodJobDB UniWorX)
               ()
     feed sId val = do
       mSink <- gets $ Map.lookup sId
@@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do
   when (not $ null ignored) $ 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)

src/Handler/Utils/Table/Pagination.hs

@@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination
   , widgetColonnade, formColonnade, dbColonnade
   , cell, textCell, stringCell, i18nCell
   , anchorCell, anchorCell', anchorCellM, anchorCellM'
-  , tickmarkCell
+  , tickmarkCell, cellTooltip
   , listCell
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
@@ -339,8 +339,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   
   -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
   --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
-  dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
+  dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
-  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
+  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
   -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
@@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell True  = textCell (tickmark :: Text)
 tickmarkCell False = mempty
 
+cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
+cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt)
+  where
+    tipWdgt = [whamlet|
+        <div .js-tooltip>
+          <div .tooltip__handle>
+          <div .tooltip__content>_{msg}
+      |]
+
 
 anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
 anchorCell = anchorCellM . return

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,9 +1,10 @@
 {-# 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)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -13,6 +14,7 @@ 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 Data.Fixed             as Import
@@ -25,3 +27,21 @@ 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 Data.Hashable          as Import
+import Data.List.NonEmpty     as Import (NonEmpty(..))
+
+import Control.Monad.Morph    as Import (MFunctor(..))
+
+
+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,298 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , TemplateHaskell
+           , OverloadedStrings
+           , FlexibleContexts
+           , ViewPatterns
+           , TypeFamilies
+           , DeriveGeneric
+           , DeriveDataTypeable
+           , QuasiQuotes
+           , NamedFieldPuns
+           , MultiWayIf
+  #-}
+
+module Jobs
+  ( module Types
+  , module Jobs.Queue
+  , handleJobs
+  ) where
+
+import Import hiding (Proxy)
+
+import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
+import Jobs.Types (JobCtl(JobCtlQueue))
+import Jobs.Queue
+import Jobs.TH
+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)
+
+import Cron
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict (HashMap)
+
+import qualified Data.List.NonEmpty as NonEmpty
+
+import Data.Foldable (foldrM)
+
+import Control.Monad.Trans.Reader (mapReaderT)
+import Control.Monad.Trans.State (StateT, evalStateT, mapStateT)
+import qualified Control.Monad.State.Class as State
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Logger
+
+import Control.Monad.Random (MonadRandom(..), evalRand)
+
+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
+
+  
+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) => [TMChan JobCtl] -> UniWorX -> m ()
+-- | 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 recvChans foundation@UniWorX{..} = do
+  jobCrontab <- liftIO $ newTVarIO HashMap.empty
+  jobConfirm <- liftIO $ newTVarIO HashMap.empty
+
+  forM_ (zip [1..] recvChans) $ \(n, chan) ->
+    let
+      logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
+      logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
+      doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
+    in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
+
+  -- Start cron operation
+  void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
+  liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+    writeJobCtlBlock JobCtlDetermineCrontab
+
+
+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 = flip evalStateT HashMap.empty . forever $ 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
+  
+  now <- liftIO getCurrentTime
+  (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do
+    crontab <- liftBase . readTVar =<< asks jobCrontab
+    State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
+    prevExec <- State.get
+    case earliestJob prevExec crontab now of
+      Nothing -> liftBase retry
+      Just (_, MatchNone) -> liftBase retry
+      Just x -> return (crontab, x)
+
+  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
+                    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 . flip writeTVar 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
+  where
+    acc :: NominalDiffTime
+    acc = 1e-3
+
+    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 :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+    earliestJob 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) now cron
+
+    waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
+    waitUntil crontabTV crontab nextTime = runResourceT $ do
+      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+      let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+          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 $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
+            let
+              awaitDelayThread = False <$ takeTMVar retVar
+              awaitCrontabChange = do
+                crontab' <- readTVar crontabTV
+                True <$ guard (crontab /= crontab')
+            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+            bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+
+
+handleJobs' :: Int -> 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 . flip writeTVar 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,106 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , FlexibleContexts
+           , MultiWayIf
+           , NamedFieldPuns
+           , TypeFamilies
+  #-}
+
+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
+          }             
+      
+      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/HelpRequest.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , RecordWildCards
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.HelpRequest
+  ( dispatchJobHelpRequest
+  ) where
+
+import Import hiding ((.=))
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+import Handler.Utils.DateTime
+
+import Utils.Lens
+
+import Data.Bitraversable
+  
+
+dispatchJobHelpRequest :: Either (Maybe Email) 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 (fmap $ Address Nothing)
+                           (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,62 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+  #-}
+
+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] [] 
+  
+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
+
+

src/Jobs/Handler/SendNotification.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+  #-}
+
+module Jobs.Handler.SendNotification
+  ( dispatchJobSendNotification
+  ) where
+
+import Import
+
+import Jobs.TH
+import Jobs.Types
+
+
+import Jobs.Handler.SendNotification.SubmissionRated
+import Jobs.Handler.SendNotification.SheetActive
+import Jobs.Handler.SendNotification.SheetInactive
+import Jobs.Handler.SendNotification.CorrectionsAssigned
+
+
+dispatchJobSendNotification :: UserId -> Notification -> Handler ()
+dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.CorrectionsAssigned
+  ( dispatchNotificationCorrectionsAssigned
+  ) where
+
+import Import
+
+import Utils.Lens
+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 $ 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/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.SheetActive
+  ( dispatchNotificationSheetActive
+  ) where
+
+import Import
+
+import Utils.Lens
+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,58 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.SheetInactive
+  ( dispatchNotificationSheetSoonInactive
+  , dispatchNotificationSheetInactive
+  ) where
+
+import Import
+
+import Utils.Lens
+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,59 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+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
+  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..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
+      , "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,34 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , QuasiQuotes
+  #-}
+
+module Jobs.Handler.SendTestEmail
+  ( dispatchJobSendTestEmail
+  ) where
+
+import Import hiding ((.=))
+
+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))

src/Jobs/Handler/SetLogSettings.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude
+  #-}
+
+module Jobs.Handler.SetLogSettings
+  ( dispatchJobSetLogSettings
+  ) where
+
+import Import
+
+dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
+dispatchJobSetLogSettings jInstance jLogSettings = do
+  instanceId <- getsYesod appInstanceID
+  unless (instanceId == jInstance) $ fail "Incorrect instance"
+  lSettings <- getsYesod appLogSettings
+  atomically $ writeTVar lSettings jLogSettings

src/Jobs/Queue.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TypeFamilies
+  #-}
+
+module Jobs.Queue
+  ( writeJobCtl, writeJobCtlBlock
+  , queueJob, queueJob'
+  , YesodJobDB
+  , runDBJobs, queueDBJob
+  ) where
+
+import Import
+
+import Utils.Sql
+import Jobs.Types
+
+import Control.Monad.Trans.Writer (WriterT, runWriterT)
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
+
+import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.HashMap.Strict as HashMap
+
+import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
+
+
+writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
+writeJobCtl cmd = do
+  tid <- liftIO myThreadId
+  chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
+  liftIO . atomically $ writeTMChan chan cmd
+
+writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
+writeJobCtlBlock cmd = do
+  getResVar <- asks jobConfirm
+  resVar <- liftIO . atomically $ do
+    var <- newEmptyTMVar
+    modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
+    return var
+  lift $ writeJobCtl cmd
+  let
+    removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd 
+  mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
+  maybe (return ()) throwM mExc
+
+queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe job = do
+  now <- liftIO getCurrentTime
+  self <- getsYesod appInstanceID
+  insert QueuedJob
+    { queuedJobContent = toJSON job
+    , queuedJobCreationInstance = self
+    , queuedJobCreationTime = now
+    , queuedJobLockInstance = Nothing
+    , queuedJobLockTime = Nothing
+    }
+  -- We should not immediately notify a worker; instead wait for the transaction to finish first
+  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+  -- return jId
+
+queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
+
+queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
+-- ^ `queueJob` followed by `JobCtlPerform`
+queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
+
+type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
+
+queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
+queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
+
+runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+runDBJobs act = do
+  (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
+  forM_ jIds $ writeJobCtl . JobCtlPerform
+  return ret
+
+
+

src/Jobs/TH.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , QuasiQuotes
+           , RecordWildCards
+  #-}
+
+module Jobs.TH
+  ( dispatchTH
+  ) where
+
+import ClassyPrelude
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+import Data.List (foldl)
+
+
+dispatchTH :: Name -- ^ Datatype to pattern match
+           -> ExpQ
+dispatchTH dType = do
+  DatatypeInfo{..} <- reifyDatatype dType
+  let
+    matches = map mkMatch datatypeCons
+    mkMatch ConstructorInfo{..} = do
+      pats <- forM constructorFields $ \_ -> newName "x"
+      let fName = mkName $ "dispatch" <> nameBase constructorName
+      match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
+  lamCaseE matches

src/Jobs/Types.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE TemplateHaskell
+           , NoImplicitPrelude
+           , DeriveGeneric
+           , DeriveDataTypeable
+  #-}
+
+module Jobs.Types
+  ( Job(..), Notification(..)
+  , JobCtl(..)
+  , JobContext(..)
+  ) where
+
+import Import.NoFoundation
+
+import Data.Aeson (defaultOptions, Options(..), SumEncoding(..))
+import Data.Aeson.TH (deriveJSON)
+
+import Data.List.NonEmpty (NonEmpty)
+
+
+data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+         | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
+         | JobQueueNotification { jNotification :: Notification }
+         | JobHelpRequest { jSender :: Either (Maybe Email) UserId
+                          , jRequestTime :: UTCTime
+                          , jHelpRequest :: Text, jReferer :: Maybe Text }
+         | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }         
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
+                  | NotificationSheetActive { nSheet :: SheetId }
+                  | NotificationSheetSoonInactive { nSheet :: SheetId }
+                  | NotificationSheetInactive { nSheet :: SheetId }
+                  | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+
+instance Hashable Job
+instance Hashable Notification
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "job" "data"
+  } ''Job
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "notification" "data"
+  } ''Notification
+
+
+data JobCtl = JobCtlFlush
+            | JobCtlPerform QueuedJobId
+            | JobCtlDetermineCrontab
+            | JobCtlQueue Job
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable JobCtl
+
+
+data JobContext = JobContext
+  { jobCrontab :: TVar (Crontab JobCtl)
+  , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
+  }

src/Mail.hs

@@ -0,0 +1,485 @@
+{-# LANGUAGE NoImplicitPrelude
+           , GeneralizedNewtypeDeriving
+           , DerivingStrategies
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , DeriveGeneric
+           , TemplateHaskell
+           , OverloadedStrings
+           , RecordWildCards
+           , FlexibleContexts
+           , TypeFamilies
+           , ViewPatterns
+           , NamedFieldPuns
+           , MultiWayIf
+           , QuasiQuotes
+           , RankNTypes
+           , ScopedTypeVariables
+           , DeriveDataTypeable
+  #-}
+
+module Mail
+  ( -- * Structured MIME emails
+    module Network.Mail.Mime
+    -- * MailT
+  , MailT, defMailT
+  , MailSmtpData(..), MailContext(..), MailLanguages(..)
+  , MonadMail(..)
+  , getMailMessageRender, getMailMsgRenderer
+    -- * YesodMail
+  , VerpMode(..)
+  , YesodMail(..)
+  , MailException(..)
+    -- * Monadically constructing Mail
+  , PrioritisedAlternatives
+  , ToMailPart(..)
+  , addAlternatives, provideAlternative, providePreferredAlternative
+  , addPart
+  , MonadHeader(..)
+  , MailHeader
+  , MailObjectId
+  , replaceMailHeader, addMailHeader, removeMailHeader
+  , replaceMailHeaderI, addMailHeaderI
+  , setSubjectI, setMailObjectId, setMailObjectId'
+  , setDate, setDateCurrent
+  , setMailSmtpData
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
+  , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
+  ) where
+
+import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)
+
+import Network.Mail.Mime hiding (addPart, addAttachment)
+import qualified Network.Mail.Mime as Mime (addPart)
+
+import Data.Monoid (Last(..))
+import Control.Monad.Trans.RWS (RWST(..), execRWST)
+import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT)
+import Control.Monad.Trans.Writer (execWriter, Writer)
+import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
+import Control.Monad.Fail
+
+import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Data.Data (Data)
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import qualified Data.Text as Text
+
+import qualified Data.Foldable as Foldable
+
+import Data.Hashable
+
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as LTB
+import qualified Data.ByteString.Lazy as LBS
+
+import Utils (MsgRendererS(..))
+import Utils.Lens.TH
+import Control.Lens
+
+import Text.Blaze.Renderer.Utf8
+
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Data.UUID.Cryptographic.ImplicitNamespace
+
+import Data.Binary (Binary)
+
+import GHC.TypeLits (KnownSymbol)
+
+import Network.BSD (getHostName)
+
+import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
+import Data.Time.LocalTime (ZonedTime(..))
+import Data.Time.Format
+
+import Network.HaskellNet.SMTP (SMTPConnection)
+import qualified Network.HaskellNet.SMTP as SMTP
+
+import qualified Text.Hamlet as Hamlet (Translate)
+import qualified Text.Shakespeare as Shakespeare (RenderUrl)
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import Data.Aeson (Options(..))
+import Data.Aeson.TH
+import Utils (MsgRendererS(..))
+import Utils.PathPiece (splitCamel)
+import Utils.DateTime
+
+import Data.Universe.Instances.Reverse ()
+import Data.Universe.Instances.Reverse.JSON ()
+import Data.Universe.Instances.Reverse.Hashable ()
+
+makeLenses_ ''Mail
+makeLenses_ ''Part
+
+
+newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a }
+  deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
+                   , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
+                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
+                   )
+
+instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
+  type MonadCryptoKey (MailT m) = CryptoIDKey
+  cryptoIDKey f = lift (cryptoIDKey return) >>= f
+
+data MailSmtpData = MailSmtpData
+  { smtpEnvelopeFrom :: Last Text
+  , smtpRecipients :: Set Text
+  } deriving (Eq, Ord, Show, Read, Generic)
+
+instance Monoid (MailSmtpData) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+  deriving newtype (FromJSON, ToJSON)
+
+instance Default MailLanguages where
+  def = MailLanguages []
+
+instance Hashable MailLanguages
+
+data MailContext = MailContext
+  { mcLanguages :: MailLanguages
+  , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''MailContext
+
+instance Hashable MailContext
+instance Default MailContext where
+  def = MailContext { mcLanguages = def
+                    , mcDateTimeFormat = def
+          }
+
+makeLenses_ ''MailContext
+
+class (MonadHandler m, MonadState Mail m) => MonadMail m where
+  askMailLanguages :: m MailLanguages
+  askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
+  tellMailSmtpData :: MailSmtpData -> m ()
+
+instance MonadHandler m => MonadMail (MailT m) where
+  askMailLanguages = view _mcLanguages
+  askMailDateTimeFormat = (view _mcDateTimeFormat ??)
+  tellMailSmtpData = tell
+
+data VerpMode = VerpNone
+              | Verp { verpSeparator, verpAtReplacement :: Char }
+  deriving (Eq, Show, Read)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
+
+getMailMessageRender :: ( MonadMail m
+                        , HandlerSite m ~ site
+                        , RenderMessage site msg
+                        ) => m (msg -> Text)
+getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+
+getMailMsgRenderer :: forall site m.
+                      ( MonadMail m
+                      , HandlerSite m ~ site
+                      ) => m (MsgRendererS site)
+getMailMsgRenderer = do
+  mr <- getMailMessageRender
+  return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
+
+
+data MailException = MailNotAvailable
+                   | MailNoSenderSpecified
+                   | MailNoRecipientsSpecified
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception MailException
+  
+
+class Yesod site => YesodMail site where
+  defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
+  defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
+
+  mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
+  mailObjectIdDomain = pack <$> liftIO getHostName
+
+  mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
+  mailDateTZ = return utcTZ
+
+  mailSmtp :: ( MonadHandler m
+              , HandlerSite m ~ site
+              , MonadBaseControl IO m
+              ) => (SMTPConnection -> m a) -> m a
+  mailSmtp _ = throwM MailNotAvailable
+
+  mailVerp :: ( MonadHandler m
+              , HandlerSite m ~ site
+              ) => m VerpMode
+  mailVerp = return VerpNone
+
+  mailT :: ( MonadHandler m
+           , HandlerSite m ~ site
+           , MonadBaseControl IO m
+           , MonadLogger m
+           ) => MailContext -> MailT m a -> m a
+  mailT = defMailT
+
+  defaultMailLayout :: ( MonadHandler m
+                       , HandlerSite m ~ site
+                       ) => WidgetT site IO () -> m Html
+  defaultMailLayout wgt = do
+    PageContent{..} <- liftHandlerT $ widgetToPageContent wgt
+    msgs <- getMessages
+    withUrlRenderer [hamlet|
+      $newline never
+      $doctype 5
+      <html>
+        <head>
+          <title>#{pageTitle}
+          ^{pageHead}
+        <body>
+          $forall (status, msg) <- msgs
+            <p class="message #{status}">#{msg}
+        ^{pageBody}
+    |]
+
+defMailT :: ( MonadHandler m
+            , YesodMail (HandlerSite m)
+            , MonadBaseControl IO m
+            , MonadLogger m
+            ) => MailContext
+              -> MailT m a
+              -> m a
+defMailT ls (MailT mail) = do
+  fromAddress <- defaultFromAddress
+  (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
+  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
+  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
+  ret <$ case smtpData of
+    MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
+    MailSmtpData{ smtpRecipients }
+      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
+    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
+                , smtpRecipients = (map unpack . toList -> recipients)
+                } -> mailSmtp $ \conn -> do
+      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
+      liftIO $ SMTP.sendMail
+        returnPath
+        recipients
+        mail'
+        conn
+
+
+data PrioritisedAlternatives m = PrioritisedAlternatives
+  { preferredAlternative :: Last (m Part)
+  , otherAlternatives :: Seq (m Part)
+  } deriving (Generic)
+
+instance Monoid (PrioritisedAlternatives m) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+class YesodMail site => ToMailPart site a where
+  type MailPartReturn site a :: *
+  type MailPartReturn site a = ()
+  toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
+
+instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
+  type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
+  toMailPart = mapStateT liftHandlerT
+
+instance YesodMail site => ToMailPart site LT.Text where
+  toMailPart text = do
+    _partType .= "text/plain; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= encodeUtf8 text
+
+instance YesodMail site => ToMailPart site Text where
+  toMailPart = toMailPart . LT.fromStrict
+
+instance YesodMail site => ToMailPart site LTB.Builder where
+  toMailPart = toMailPart . LTB.toLazyText
+
+instance YesodMail site => ToMailPart site Html where
+  toMailPart html = do
+    _partType .= "text/html; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= renderMarkup html
+
+instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
+  type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
+  toMailPart act = do
+    mr <- lift getMailMessageRender
+    toMailPart $ act (toHtml . mr)
+
+instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
+  type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
+  toMailPart act = do
+    mr <- lift getMailMsgRenderer
+    toMailPart $ act mr
+
+instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
+  type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
+  toMailPart act = do
+    ur <- getUrlRenderParams
+    toMailPart $ act ur
+
+instance YesodMail site => ToMailPart site Aeson.Value where
+  toMailPart val = do
+    _partType .= "application/json; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= Aeson.encodePretty val
+
+
+addAlternatives :: (MonadMail m)
+                => Writer (PrioritisedAlternatives m) ()
+                -> m ()
+addAlternatives provided = do
+  let PrioritisedAlternatives{..} = execWriter provided
+  alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
+  modify $ Mime.addPart alternatives
+
+provideAlternative, providePreferredAlternative
+  :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
+  => a
+  -> Writer (PrioritisedAlternatives m) ()
+provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
+providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
+
+addPart :: ( MonadMail m
+           , HandlerSite m ~ site
+           , ToMailPart site a
+           ) => a -> m (MailPartReturn site a)
+addPart part = do
+  (ret, part') <- runStateT (toMailPart part) initialPart
+  modify . Mime.addPart $ pure part'
+  return ret
+
+initialPart :: Part
+initialPart = Part
+  { partType = "text/plain"
+  , partEncoding = None
+  , partFilename = Nothing
+  , partHeaders = []
+  , partContent = mempty
+  }
+
+
+class MonadHandler m => MonadHeader m where
+  modifyHeaders :: (Headers -> Headers) -> m ()
+  objectIdHeader :: m MailHeader
+
+instance MonadHandler m => MonadHeader (MailT m) where
+  modifyHeaders f = MailT . modify $ over _mailHeaders f
+  objectIdHeader = return "Message-ID"
+
+instance MonadHandler m => MonadHeader (StateT Part m) where
+  modifyHeaders f = _partHeaders %= f
+  objectIdHeader = return "Content-ID"
+
+
+type MailHeader = ByteString
+type MailObjectId = Text
+
+
+replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
+replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
+
+addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
+addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
+
+removeMailHeader :: MonadHeader m => MailHeader -> m ()
+removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
+
+
+replaceMailHeaderI :: ( RenderMessage site msg
+                      , MonadMail m
+                      , HandlerSite m ~ site
+                      , MonadHeader m
+                      ) => MailHeader -> msg -> m ()
+replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
+  
+addMailHeaderI :: ( RenderMessage site msg
+                  , MonadMail m
+                  , HandlerSite m ~ site
+                  , MonadHeader m
+                  ) => MailHeader -> msg -> m ()
+addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
+
+
+setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
+setSubjectI = replaceMailHeaderI "Subject"
+
+setMailObjectUUID :: ( MonadHeader m
+                     , YesodMail (HandlerSite m)
+                     ) => UUID -> m MailObjectId
+setMailObjectUUID uuid = do
+  domain <- mailObjectIdDomain
+  oidHeader <- objectIdHeader
+  let objectId = UUID.toText uuid <> "@" <> domain
+  replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
+  return objectId
+
+setMailObjectId :: ( MonadHeader m
+                   , YesodMail (HandlerSite m)
+                   ) => m MailObjectId
+setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+
+setMailObjectId' :: ( MonadHeader m
+                    , YesodMail (HandlerSite m)
+                    , MonadCrypto m
+                    , HasCryptoUUID plain m
+                    , MonadCryptoKey m ~ CryptoIDKey
+                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                    , Binary plain
+                    ) => plain -> m MailObjectId
+setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+
+
+setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
+setDateCurrent = setDate =<< liftIO getCurrentTime
+
+setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m ()
+setDate time = do
+  tz <- mailDateTZ
+  let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time)
+  replaceMailHeader "Date" . Just $ pack timeStr
+
+
+setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
+setMailSmtpData = do
+  Address _ from <- use _mailFrom
+  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
+
+  tell $ mempty { smtpRecipients = recps }
+
+  verpMode <- mailVerp
+  if
+    | Verp{..} <- verpMode
+    , [recp] <- Set.toList recps
+    -> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat
+             [ user
+             , Text.singleton verpSeparator
+             , Text.replace "@" (Text.singleton verpAtReplacement) recp
+             , domain
+             ]
+        in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp }
+    | otherwise
+    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }

src/Model.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 
@@ -14,6 +16,7 @@
 module Model
   ( module Model
   , module Model.Types
+  , module Cron.Types
   ) where
 
 import ClassyPrelude.Yesod
@@ -21,11 +24,16 @@ import Database.Persist.Quasi
 -- import Data.Time
 -- import Data.ByteString
 import Model.Types
-import Data.Aeson.TH
+import Cron.Types
+
+import Data.Aeson (Value)
+import Data.Aeson.TH (deriveJSON, defaultOptions)
 
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
 
+import Utils.Message (MessageClass)
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
@@ -35,7 +43,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 
 -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
 deriving instance Eq (Unique Course)
-
+  
 data PWEntry = PWEntry
   { pwUser :: User
   , pwHash :: Text
@@ -43,4 +51,4 @@ data PWEntry = PWEntry
 $(deriveJSON defaultOptions ''PWEntry)
 
 submissionRatingDone :: Submission -> Bool
-submissionRatingDone Submission{..} = isJust submissionRatingPoints
+submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration.hs

@@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
+    , whenM (tableExists "user") $ do
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
+          UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -5,16 +5,25 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE MultiWayIf #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types where
+module Model.Types
+  ( module Model.Types
+  , module Numeric.Natural
+  , module Mail
+  , module Utils.DateTime
+  ) where
 
 import ClassyPrelude
 import Utils
 import Control.Lens
+import Utils.Lens.TH
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -26,6 +35,8 @@ import Data.Universe
 import Data.Universe.Helpers
 import Data.UUID.Types
 
+import Data.Default
+
 import Text.Read (readMaybe)
 
 import Database.Persist.TH hiding (derivePersistFieldJSON)
@@ -40,20 +51,40 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
 
+import qualified Data.HashMap.Strict as HashMap
+
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
-import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
+import Data.Aeson.Types (toJSONKeyText)
 import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 
+import Data.Universe.Instances.Reverse ()
+
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
+import Mail (MailLanguages(..))
+import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
+
+import Numeric.Natural
+import Data.Word.Word24 (Word24)
+import Data.Bits
+import Data.Ix
+import Data.List (genericIndex, elemIndex)
+import System.Random (Random(..))
+import Data.Data (Data)
+
+import Model.Types.Wordlist
+
 
 instance PathPiece UUID where
   fromPathPiece = Data.UUID.Types.fromString . unpack
@@ -93,8 +124,9 @@ fromPoints = round
 instance DisplayAble Points
 
 data SheetType
-  = Bonus  { maxPoints :: Points }
+  = Bonus  { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
-  | Normal { maxPoints :: Points }
+  | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben
+--  | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift
   | Pass   { maxPoints, passingPoints :: Points }
   | NotGraded
   deriving (Show, Read, Eq)
@@ -108,6 +140,8 @@ instance DisplayAble SheetType where
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON ''SheetType
 
+makeLenses_ ''SheetType
+
 data SheetTypeSummary = SheetTypeSummary
   { sumBonusPoints  :: Sum Points
   , sumNormalPoints :: Sum Points
@@ -130,13 +164,15 @@ sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
 
 
 data SheetGroup
-  = Arbitrary { maxParticipants :: Int }
+  = Arbitrary { maxParticipants :: Natural }
   | RegisteredGroups
   | NoGroups
   deriving (Show, Read, Eq)
 deriveJSON defaultOptions ''SheetGroup
 derivePersistFieldJSON ''SheetGroup
 
+makeLenses_ ''SheetGroup
+
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
@@ -201,6 +237,16 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
 deriveJSON defaultOptions ''UploadMode
 derivePersistFieldJSON ''UploadMode
 
+data SheetSubmissionMode = NoSubmissions
+                         | CorrectorSubmissions
+                         | UserSubmissions
+  deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . splitCamel
+  } ''SheetSubmissionMode
+derivePersistField "SheetSubmissionMode"
+
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
@@ -216,8 +262,6 @@ deriveJSON defaultOptions ''Load
 derivePersistFieldJSON ''Load
 
 
-
-
 instance Semigroup Load where
   (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
     where
@@ -332,7 +376,7 @@ instance PathPiece TermIdentifier where
   toPathPiece = termToText
 
 instance ToJSON TermIdentifier where
-  toJSON = String . termToText
+  toJSON = Aeson.String . termToText
 
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
@@ -355,6 +399,16 @@ data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
 
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . toASCIIBytes
+  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
 instance DisplayAble StudyFieldType
 
 data Theme
@@ -391,12 +445,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
     fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
     toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
 
-newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
-  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
-
-data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
-  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
 
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -429,14 +477,160 @@ deriveJSON defaultOptions
 
 derivePersistFieldJSON ''AuthenticationMode
 
-  
+
+derivePersistFieldJSON ''Value
+
+
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
+--
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger = NTSubmissionRatedGraded
+                         | NTSubmissionRated
+                         | NTSheetActive
+                         | NTSheetSoonInactive
+                         | NTSheetInactive
+                         | NTCorrectionsAssigned
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+    NTSheetActive -> True
+    NTSheetSoonInactive -> False
+    NTSheetInactive -> True
+    NTCorrectionsAssigned -> True
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
+derivePersistFieldJSON ''NotificationSettings
+
+
+instance ToBackendKey SqlBackend record => Hashable (Key record) where
+  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
+
+
+derivePersistFieldJSON ''MailLanguages
+
+
+newtype Pseudonym = Pseudonym Word24
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix)
+
+
+instance PersistField Pseudonym where
+  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
+  fromPersistValue v = do
+    w <- fromPersistValue v :: Either Text Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> Left "Pseudonym out of range"
+
+instance PersistFieldSql Pseudonym where
+  sqlType _ = SqlInt32
+
+instance Random Pseudonym where
+  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
+  random = randomR (minBound, maxBound)
+
+instance FromJSON Pseudonym where
+  parseJSON v@(Aeson.Number _) = do
+    w <- parseJSON v :: Aeson.Parser Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> fail "Pseudonym out auf range"
+  parseJSON (Aeson.String (map CI.mk . Text.words -> ws))
+    = case preview pseudonymWords ws of
+        Just p -> return p
+        Nothing -> fail "Could not parse pseudonym"
+  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
+    ws' <- toList . map CI.mk <$> mapM parseJSON ws
+    case preview pseudonymWords ws' of
+      Just p -> return p
+      Nothing -> fail "Could not parse pseudonym words"
+
+instance ToJSON Pseudonym where
+  toJSON = toJSON . (review pseudonymWords :: Pseudonym -> [PseudonymWord])
+
+pseudonymWordlist :: [PseudonymWord]
+pseudonymWordlist = $(wordlist "config/wordlist.txt")
+
+pseudonymWords :: Prism' [PseudonymWord] Pseudonym
+pseudonymWords = prism' pToWords pFromWords
+  where
+    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
+    pFromWords [w1, w2]
+      | Just i1 <- elemIndex w1 pseudonymWordlist
+      , Just i2 <- elemIndex w2 pseudonymWordlist
+      , i1 <= maxWord, i2 <= maxWord
+      = Just $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
+    pFromWords _ = Nothing
+
+    pToWords :: Pseudonym -> [PseudonymWord]
+    pToWords (Pseudonym p)
+      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
+        , genericIndex pseudonymWordlist $ p .&. maxWord
+        ]
+
+    maxWord :: Num a => a
+    maxWord = 0b111111111111
+
+pseudonymText :: Prism' Text Pseudonym
+pseudonymText = iso tFromWords tToWords . pseudonymWords
+  where
+    tFromWords :: Text -> [PseudonymWord]
+    tFromWords = map CI.mk . Text.words
+
+    tToWords :: [PseudonymWord] -> Text
+    tToWords = Text.unwords . map CI.original
+
+
 -- Type synonyms
 
+type PseudonymWord   = CI Text
+
+type Email           = Text
+
 type SchoolName      = CI Text
 type SchoolShorthand = CI Text
 type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
-type UserEmail       = CI Text
+type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type InstanceId      = UUID

src/Model/Types/JSON.hs

@@ -50,7 +50,7 @@ derivePersistFieldJSON n = do
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
       [ funD (mkName "sqlType")
-        [ clause [wildP] (normalB [e|SqlOther "json"|]) []
+        [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]
     ]

src/Model/Types/Wordlist.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+  #-}
+
+module Model.Types.Wordlist (wordlist) where
+
+import ClassyPrelude hiding (lift)
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+import qualified Data.CaseInsensitive as CI
+
+wordlist :: FilePath -> ExpQ
+wordlist file = do
+  qAddDependentFile file
+  wordlist' <- runIO $ filter ((||) <$> not . isComment <*> isWord) . Text.lines <$> Text.readFile file
+  listE $ map (\(Text.unpack -> word) -> [e|CI.mk $ Text.pack $(lift word)|]) wordlist'
+
+isWord :: Text -> Bool
+isWord t
+  | [w] <- Text.words t
+  , w == t
+  = True
+  | otherwise
+  = False
+
+isComment :: Text -> Bool
+isComment line = or
+  [ commentSymbol `Text.isPrefixOf` Text.stripStart line
+  , Text.null $ Text.strip line
+  ]
+  where
+    commentSymbol = "#"

src/Settings.hs

@@ -1,9 +1,13 @@
-{-# LANGUAGE CPP               #-}
+{-# LANGUAGE CPP                #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE MultiWayIf         #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
@@ -15,7 +19,7 @@ module Settings where
 import           ClassyPrelude.Yesod
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject,
-                                              (.!=), (.:?))
+                                              (.!=), (.:?), withScientific)
 import qualified Data.Aeson.Types as Aeson
 import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
@@ -29,6 +33,12 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileReload)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
+import Data.Time (NominalDiffTime)
+
+import Data.Scientific (toBoundedInteger)
+import Data.Word (Word16)
+
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
@@ -39,6 +49,13 @@ import Control.Lens
 import Data.Maybe (fromJust)
 import qualified Data.Char as Char
 
+import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
+import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
+
+import Network.Mail.Mime (Address)
+
+import Mail (VerpMode)
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -51,6 +68,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the database.
     , appLdapConf               :: Maybe LdapConf
     -- ^ Configuration settings for accessing the LDAP-directory
+    , appSmtpConf               :: Maybe SmtpConf
+    -- ^ Configuration settings for accessing a SMTP Mailserver
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -61,11 +80,20 @@ data AppSettings = AppSettings
     , appIpFromHeader           :: Bool
     -- ^ Get the IP address from the header when logging. Useful when sitting
     -- behind a reverse proxy.
+    , appMailFrom               :: Address
+    , appMailObjectDomain       :: Text
+    , appMailVerp               :: VerpMode
+    , appMailSupport            :: Address
+    , appJobWorkers             :: Int
+    , appJobFlushInterval       :: Maybe NominalDiffTime
+    , appJobCronInterval        :: NominalDiffTime
+    , appJobStaleThreshold      :: NominalDiffTime
+    , appNotificationRateLimit  :: NominalDiffTime
+    , appNotificationCollateDelay :: NominalDiffTime
+    , appNotificationExpiration :: NominalDiffTime
+
+    , appInitialLogSettings     :: LogSettings
 
-    , appDetailedRequestLogging :: Bool
-    -- ^ Use detailed request logging system
-    , appShouldLogAll           :: Bool
-    -- ^ Should all log messages be displayed?
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
     , appMutableStatic          :: Bool
@@ -76,26 +104,38 @@ data AppSettings = AppSettings
     -- ^ Indicate if auth dummy login should be enabled.
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
-    , appMinimumLogLevel        :: LogLevel
 
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
 
     , appCryptoIDKeyFile        :: FilePath
-    }
+    , appInstanceIDFile         :: Maybe FilePath
-  
+    } deriving (Show)
+
+data LogSettings = LogSettings
+  { logAll, logDetailed :: Bool
+  , logMinimumLevel :: LogLevel
+  } deriving (Show, Read, Generic, Eq, Ord)
+
+deriving instance Generic LogLevel
+instance Hashable LogLevel
+instance Hashable LogSettings
+
 data UserDefaultConf = UserDefaultConf
   { userDefaultTheme :: Theme
   , userDefaultMaxFavourites :: Int
   , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
   , userDefaultDownloadFiles :: Bool
-  }
+  } deriving (Show)
  
 data PWHashConf = PWHashConf
   { pwHashAlgorithm :: PWHashAlgorithm
   , pwHashStrength :: Int
   }
 
+instance Show PWHashConf where
+  show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
+
 instance FromJSON PWHashConf where
   parseJSON = withObject "PWHashConf" $ \o -> do
     pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
@@ -113,8 +153,35 @@ data LdapConf = LdapConf
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
   , ldapTimeout :: Int32
-  }
+  } deriving (Show)
  
+data SmtpConf = SmtpConf
+  { smtpHost :: HaskellNet.HostName
+  , smtpPort :: HaskellNet.PortNumber
+  , smtpAuth :: Maybe SmtpAuthConf
+  , smtpSsl  :: SmtpSslMode
+  , smtpPool :: ResourcePoolConf
+  } deriving (Show)
+
+data ResourcePoolConf = ResourcePoolConf
+  { poolStripes :: Int
+  , poolTimeout :: NominalDiffTime
+  , poolLimit :: Int
+  } deriving (Show)
+
+data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
+  deriving (Show)
+
+data SmtpAuthConf = SmtpAuthConf
+  { smtpAuthType :: HaskellNet.AuthType
+  , smtpAuthUsername :: HaskellNet.UserName
+  , smtpAuthPassword :: HaskellNet.Password
+  } deriving (Show)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . splitCamel
+  } ''LogSettings
+  
 deriveFromJSON defaultOptions ''Ldap.Scope
 deriveFromJSON defaultOptions
   { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
@@ -140,12 +207,64 @@ instance FromJSON LdapConf where
         return LdapConf{..}
 
 deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''ResourcePoolConf
+
+deriveJSON
   defaultOptions
     { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
     , sumEncoding = UntaggedValue
     }
   ''LogLevel
 
+instance FromJSON HaskellNet.PortNumber where
+  parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
+    Just int -> return $ fromIntegral (int :: Word16)
+    Nothing -> fail "Expected whole number of plausible size to denote port"
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
+    , allNullaryToStringTag = True
+    }
+  ''HaskellNet.AuthType
+
+instance FromJSON SmtpConf where
+  parseJSON = withObject "SmtpConf" $ \o -> do
+    smtpHost <- o .: "host"
+    smtpPort <- o .: "port"
+    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
+    smtpSsl <- o .: "ssl"
+    smtpPool <- o .: "pool"
+    return SmtpConf{..}
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+    , allNullaryToStringTag = True
+    }
+  ''SmtpSslMode
+
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = let
+                             nameMap "username" = "user"
+                             nameMap "password" = "pass"
+                             nameMap x = x
+                           in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel
+    }
+  ''SmtpAuthConf
+
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''Address
+
+
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -160,24 +279,38 @@ instance FromJSON AppSettings where
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host
         appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
+        appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
 
-        appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
+        appMailFrom               <- o .: "mail-from"
-        appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
+        appMailObjectDomain       <- o .: "mail-object-domain"
-        appMinimumLogLevel        <- o .:  "minimum-log-level"
+        appMailVerp               <- o .: "mail-verp"
+        appMailSupport            <- o .: "mail-support"
+
+        appJobWorkers             <- o .:  "job-workers"
+        appJobFlushInterval       <- o .:? "job-flush-interval"
+        appJobCronInterval        <- o .:  "job-cron-interval"
+        appJobStaleThreshold      <- o .:  "job-stale-threshold"
+        appNotificationRateLimit  <- o .:  "notification-rate-limit"
+        appNotificationCollateDelay <- o .: "notification-collate-delay"
+        appNotificationExpiration <- o .: "notification-expiration"
+
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
         appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
 
+        appInitialLogSettings     <- o .:  "log-settings"
+
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
+        appInstanceIDFile         <- o .:? "instance-idfile"
 
         return AppSettings {..}
 

src/Utils.hs

@@ -21,11 +21,14 @@ import Data.Foldable as Fold hiding (length)
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.ByteString.Lazy as LBS
+
 import Utils.DB as Utils
 import Utils.TH as Utils
 import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Message as Utils
+import Utils.Lang as Utils
 
 
 import Text.Blaze (Markup, ToMarkup)
@@ -53,6 +56,8 @@ import Instances.TH.Lift ()
 
 import Text.Shakespeare.Text (st)
 
+import qualified Data.Aeson as Aeson
+
 
 
 -----------
@@ -312,6 +317,9 @@ maybeM dft act mb = mb >>= maybe dft act
 maybeT :: Monad m => m a -> MaybeT m a -> m a
 maybeT x m = runMaybeT m >>= maybe x return
 
+maybeT_ :: Monad m => MaybeT m () -> m ()
+maybeT_ = void . runMaybeT
+
 catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
 catchIfMaybeT p act = catchIf p (lift act) (const mzero)
 
@@ -434,3 +442,13 @@ orM = Fold.foldr or2M (return False)
 
 anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
 anyM xs f = orM $ fmap f xs
+
+--------------
+-- Sessions --
+--------------
+
+setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
+setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
+
+lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key

src/Utils/DB.hs

@@ -15,7 +15,7 @@ import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import Database.Persist -- currently not needed here
 
-
+-- ezero = E.val (0 :: Int64)
 
 emptyOrIn :: PersistField typ =>
   E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)

src/Utils/DateTime.hs

@@ -2,7 +2,13 @@
            , TemplateHaskell
            , QuasiQuotes
            , StandaloneDeriving
+           , DerivingStrategies
            , DeriveLift
+           , DeriveDataTypeable
+           , DeriveGeneric
+           , GeneralizedNewtypeDeriving
+           , OverloadedStrings
+           , FlexibleInstances
   #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -10,6 +16,8 @@ module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
   , currentYear
+  , DateTimeFormat(..)
+  , SelDateTimeFormat(..)
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -20,14 +28,29 @@ import System.Locale.Read
 import Data.Time (TimeZone(..), TimeLocale(..))
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
+import Data.Time.Clock.POSIX
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Instances.TH.Lift ()
 
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Data.Universe
+
+import Database.Persist.Sql (PersistField, PersistFieldSql)
+
+import Data.Aeson.Types (toJSONKeyText)
+import Data.Aeson
+import Data.Aeson.TH
+
+import Utils.PathPiece
+
 deriving instance Lift TimeZone
 deriving instance Lift TimeLocale
 
+instance Hashable UTCTime where
+  hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@@ -63,3 +86,31 @@ currentYear = do
   now <- runIO getCurrentTime
   let (year, _, _) = toGregorian $ utctDay now
   [e|year|]
+
+
+newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
+
+instance Hashable DateTimeFormat
+
+data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
+
+instance Universe SelDateTimeFormat
+instance Finite SelDateTimeFormat
+instance Hashable SelDateTimeFormat
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  } ''SelDateTimeFormat
+
+instance ToJSONKey SelDateTimeFormat where
+  toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt
+instance FromJSONKey SelDateTimeFormat where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
+
+instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
+  def SelFormatDateTime = "%c"
+  def SelFormatDate     = "%F"
+  def SelFormatTime     = "%T"

src/Utils/Form.hs

@@ -9,11 +9,13 @@
            , FlexibleContexts
            , NamedFieldPuns
            , ScopedTypeVariables
+           , MultiWayIf
+           , RecordWildCards
 #-}
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (addMessage)
 import Settings
 
 import qualified Text.Blaze.Internal as Blaze (null)
@@ -23,8 +25,18 @@ import qualified Data.Char as Char
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
+import Data.Map.Lazy ((!))
+import qualified Data.Map.Lazy as Map
+import qualified Data.Set as Set
+
+import Data.List ((!!))
+
 import Web.PathPieces
 
+import Data.UUID
+
+import Utils.Message
+
 -------------------
 -- Form Renderer --
 -------------------
@@ -121,8 +133,8 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
 setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
 setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
 
-addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
+addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
-addDatalist field mValues = field
+addDatalist mValues field = field
   { fieldView = \fId fName fAttrs fRes fReq -> do
       listId <- newIdent
       values <- map toPathPiece . otoList <$> mValues
@@ -135,12 +147,29 @@ addDatalist field mValues = field
       |]
   }
 
+noValidate :: FieldSettings site -> FieldSettings site
+noValidate = addAttr "formnovalidate" ""
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
+data FormIdentifier
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  = FIDcourse
+  | FIDsheet
+  | FIDsubmission
+  | FIDsettings
+  | FIDcorrectors
+  | FIDcorrectorTable
+  | FIDcorrection
+  | FIDcorrectionsUpload
+  | FIDcorrectionUpload
+  | FIDSystemMessageAdd
+  | FIDSystemMessageTable
+  | FIDSystemMessageModify
+  | FIDSystemMessageModifyTranslation UUID
+  | FIDSystemMessageAddTranslation
+  deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
   fromPathPiece = readFromPathPiece
@@ -195,7 +224,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
     fieldParse []    _ = return $ Right Nothing
     fieldParse [str] _
       | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value" -- SJ: Right Nothing?!
+      | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
 
 combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
@@ -216,3 +245,45 @@ ciField :: ( Textual t
            , RenderMessage (HandlerSite m) FormMessage
            ) => Field m (CI t)
 ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
+
+reorderField :: ( MonadHandler m
+                , HandlerSite m ~ site
+                , Eq a
+                , Show a
+                ) => HandlerT site IO (OptionList a) -> Field m [a] 
+-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
+reorderField optList = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldParse [] _ = return $ Right Nothing
+    fieldParse optlist _ = do
+      OptionList{..} <- liftHandlerT optList
+      let
+        olNum = fromIntegral $ length olOptions
+        selOptions = Map.fromList $ do
+          i <- [1..olNum]
+          (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
+          guard $ i == n
+          Just val <- return . olReadExternal $ pack extVal
+          return (i, val)
+      return $ if
+        | Map.keysSet selOptions == Set.fromList [1..olNum]
+          -> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
+        | otherwise
+          -> Left "Not a valid permutation"
+    fieldView theId name attrs val isReq = do
+      OptionList{..} <- liftHandlerT optList
+      let
+        isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
+        nums = map (id &&& withNum theId) [1..length olOptions]
+        withNum t n = tshow n <> "." <> t
+      $(widgetFile "widgets/permutation")
+
+---------------------
+-- Form evaluation --
+---------------------
+
+formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
+formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
+formResult  FormMissing       _ = return ()
+formResult (FormSuccess res)  f = f res

src/Utils/Lang.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Utils.Lang where
+
+import ClassyPrelude.Yesod
+
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
+
+import qualified Data.Text as Text
+
+
+selectLanguage :: MonadHandler m
+               => NonEmpty Lang -- ^ Available translations, first is default
+               -> m Lang
+selectLanguage avL = selectLanguage' avL <$> languages
+
+selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default
+                -> [Lang] -- ^ Languages in preference order
+                -> Lang
+selectLanguage' (defL :| _) [] = defL
+selectLanguage' avL (l:ls)
+  | not $ null l
+  , Just l' <- find (== l) (NonEmpty.toList avL)
+  = l'
+  | not $ null l
+  , Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
+  , found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL
+  = case found of
+      Just l' -> l'
+      Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
+  | otherwise = selectLanguage' avL ls
+
+langMatches :: Lang -- ^ Needle
+            -> Lang -- ^ Haystack
+            -> Bool
+langMatches = isPrefixOf `on` Text.splitOn "-"

src/Utils/Message.hs

@@ -1,35 +1,62 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveLift #-}
 
 
 module Utils.Message
   ( MessageClass(..)
-  , addMessage, addMessageI
+  , addMessage, addMessageI, addMessageIHamlet, addMessageFile
   ) where
 
 
-import Data.Text as Text (toLower)
 import Data.Universe
 import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
+import Data.Aeson
+import Data.Aeson.TH
 
 import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
-import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
+
+import Text.Hamlet
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift)
 
 
 data MessageClass = Error | Warning | Info | Success
-  deriving (Eq,Ord,Enum,Bounded,Show,Read)
+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
 
 instance Universe MessageClass
 instance Finite   MessageClass
 
 $( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
 
+deriveJSON defaultOptions
+  { constructorTagModifier = toLower
+  } ''MessageClass
+
 instance PathPiece MessageClass where
-  toPathPiece   = $(nullaryToPathPiece ''MessageClass [Text.toLower])
+  toPathPiece   = $(nullaryToPathPiece ''MessageClass [toLower])
   fromPathPiece = finiteFromPathPiece
 
+derivePersistField "MessageClass"
+
+
 addMessage :: MonadHandler m => MessageClass-> Html -> m ()
 addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)
 
 addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
 addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
+
+addMessageIHamlet :: ( MonadHandler m
+                     , RenderMessage (HandlerSite m) msg
+                     , HandlerSite m ~ site
+                     ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
+addMessageIHamlet mc iHamlet = do
+  mr <- getMessageRender
+  ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
+
+addMessageFile :: MessageClass -> FilePath -> ExpQ
+addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]

src/Utils/Sql.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NumDecimals #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Utils.Sql
+  ( setSerializable
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Database.Persist.Sql
+
+import Database.PostgreSQL.Simple (sqlErrorHint)
+import Control.Monad.Catch (handleIf)
+
+import Data.Time.Clock
+
+setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable act = setSerializable' (0 :: Integer)
+  where
+    act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
+
+    setSerializable' (min 10 -> logBackoff) =
+      handleIf
+        (\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
+        (\e -> do
+            let
+              delay :: NominalDiffTime
+              delay = 1e-3 * 2 ^ logBackoff
+            $logWarnS "Sql" $ tshow (delay, e)
+            transactionUndo
+            threadDelay . round $ delay * 1e6
+            setSerializable' (succ logBackoff)
+        )
+        act'
+

src/Utils/SystemMessage.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+  #-}
+
+module Utils.SystemMessage where
+
+import Import.NoFoundation
+
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.List (findIndex)
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+
+getSystemMessage :: MonadHandler m
+                 => NonEmpty Lang -- ^ `appLanguages`
+                 -> SystemMessageId
+                 -> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
+getSystemMessage appLanguages smId = runMaybeT $ do
+  SystemMessage{..} <- MaybeT $ get smId
+  translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
+  let
+    avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations
+  lang <- selectLanguage avL
+  return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations)

src/Utils/TH.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Utils.TH where
 -- Common Utility Functions that require TemplateHaskell
 
 -- import Data.Char
 
+import Prelude
 import Language.Haskell.TH
 -- import Control.Monad
 -- import Control.Monad.Trans.Class

src/index.md

@@ -96,3 +96,50 @@ CryptoID
   
 Model.Migration
   : Manuelle Datenbank-Migration
+
+Jobs
+  : `handleJobs` worker thread handling background jobs
+    `JobQueueException`
+    
+Jobs.Types
+  : `Job`, `Notification`, `JobCtl` Types of Jobs
+  
+Cron.Types
+  : Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden
+    können:
+  
+    `Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab`
+    
+Cron
+  : Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch`
+  
+Jobs.Queue
+  : Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den
+    Worker-Threads
+  
+    `writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der
+    lokalen Instanz
+    
+    `queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende
+    Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich
+    des Jobs anzunehmen
+    
+    `runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu
+    benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt
+    `runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen
+    Jobs an.
+    
+Jobs.TH
+  : Templatehaskell für den dispatch mechanismus für `Jobs`
+  
+Jobs.Crontab
+  : Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus
+    der Datenbank impliziten Jobs (notifications zu bestimmten zeiten,
+    aufräumaktionen, ...) ein)
+    
+Jobs.Handler.**
+  : Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts
+    aus `Jobs.Types` an einen dieser Handler
+
+Mail
+  : Monadically constructing MIME emails

start.sh

@@ -3,6 +3,7 @@
 unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true
+export LOGLEVEL=info
 export DUMMY_LOGIN=true
 export ALLOW_DEPRECATED=true
 export PWFILE=users.yml

templates/adminTest.hamlet

@@ -34,3 +34,5 @@
       Modals:
       ^{modal "Klick mich für Ajax-Test" (Left UsersR)}
       ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
+    <li>
+      ^{modal "Email-Test" (Right emailWidget')}

templates/correction-user.cassius

@@ -0,0 +1,3 @@
+.comment
+  white-space: pre-wrap
+  font-family: monospace

templates/correction-user.hamlet

@@ -36,4 +36,4 @@
     $maybe comment <- ratingComment
       <tr .table__row>
         <th .table__th>_{MsgRatingComment}
-        <td .table__td style="white-space: pre;">#{comment}
+        <td .table__td .comment>#{comment}

templates/correction.hamlet

@@ -1,11 +1,10 @@
-^{userCorrection}
+<section>
+  ^{userCorrection}
 
-<hr>
+<section> 
-  
+  <form method=post enctype=#{corrEncoding}>
-<form method=post enctype=#{corrEncoding}>
+    ^{corrForm}
-  ^{corrForm}
 
-<hr>
+<section>
-  
+  <form method=post enctype=#{uploadEncoding}>
-<form method=post enctype=#{uploadEncoding}>
+    ^{uploadForm}
-  ^{uploadForm}

templates/corrections-create.hamlet

@@ -0,0 +1,2 @@
+<form method=post action=@{CorrectionsCreateR} enctype=#{pseudonymEncoding}>
+  ^{pseudonymWidget}

templates/corrections-grade.hamlet

@@ -0,0 +1,5 @@
+<div .container>
+  <form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
+    ^{table}
+    <button type=submit>
+      _{MsgBtnSubmit}

templates/default-layout.lucius

@@ -185,6 +185,10 @@ h4 {
   p {
     margin: 10px 0;
   }
+
+  p:last-child {
+    margin: 10px 0 0;
+  }
 }
 
 .logged-in {
@@ -309,6 +313,10 @@ input[type="button"].btn-info:hover,
   width: 100%;
 }
 
+.table:only-child {
+    margin: 0;
+}
+
 .table--striped {
 
   .table__row:not(.no-stripe):nth-child(even) {
@@ -502,3 +510,20 @@ input[type="button"].btn-info:hover,
     padding-right: 15px;
   }
 }
+
+section {
+    padding: 0 0 12px;
+    margin: 0 0 12px;
+    border-bottom: 1px solid #d3d3d3;
+    
+}
+
+section:last-of-type {
+    padding: 0;
+    margin: 0;
+    border-bottom: none;
+}
+
+.pseudonym {
+    font-family: monospace;
+}

templates/deletedUser.hamlet

@@ -0,0 +1,16 @@
+<div .container>
+  <h1>
+    _{MsgUserAccountDeleted userDisplayName}
+  <div .container>
+    #{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht.
+  $if groupSubmissions > 0
+    <div .container>
+      #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank,
+      aber die Zuordnung zum Benutzer wurden gelöscht.
+      Gruppenabgaben können dadurch zu Einzelabgaben werden,
+      welche dann vom letzten Benutzer gelöscht werden können.
+  $if deletedSubmissionGroups > 0
+    <div .container>
+      #{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden.
+  <div .container>
+    Good Bye!

templates/help.hamlet

@@ -0,0 +1,4 @@
+_{MsgHelpIntroduction}
+
+<form method=post action=@{HelpR} enctype=#{formEnctype}>
+   ^{formWidget}

templates/home.hamlet

@@ -1,11 +1,5 @@
 <div .container>
-
+  <h2>
-  <h1>
     Kurse mit offener Registrierung
   <div .container>
     ^{courseTable}
-
-  <h3>
-    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
-
-  ^{features}

templates/homeUser.hamlet

@@ -1,13 +1,10 @@
 <div .container>
-  <h3>
+  <h2>
-    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
-
-<div .container>
-  <h1>
     Anstehende Übungsblätter
   <div .container>
     ^{sheetTable}
 
+<!--
 <div .container>
   <h1>
     Anstehende Klausuren
@@ -17,3 +14,4 @@
   <h1>
     Anstehende Kursanmeldungen
   TODO
+-->

templates/mail/correctionsAssigned.hamlet

@@ -0,0 +1,18 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailCorrectionsAssignedIntro (CI.original courseName) termDesc sheetName nbrSubs}
+    <p>
+      <a href=@{CorrectionsR}>
+        _{MsgCorrectionsTitle}
+    ^{editNotifications}

templates/mail/editNotifications.hamlet

@@ -0,0 +1,4 @@
+<p>      
+  <a href=@{ProfileR}>
+    _{MsgProfileHeading}
+  \ _{MsgMailEditNotifications}

templates/mail/sheetActive.hamlet

@@ -0,0 +1,18 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}
+    ^{editNotifications}

templates/mail/sheetInactive.hamlet

@@ -0,0 +1,18 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}
+    ^{editNotifications}

templates/mail/sheetSoonInactive.hamlet

@@ -0,0 +1,18 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetSoonInactiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}
+    ^{editNotifications}

templates/mail/submissionRated.hamlet

@@ -0,0 +1,66 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+
+      .comment {
+        white-space: pre-wrap;
+        font-family: monospace;
+      }
+  <body>
+    <h1>
+      _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
+    <dl>
+      <dt>
+        _{MsgSubmission}
+      <dd>
+        <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
+          #{display csid}
+      $maybe User{..} <- corrector
+        <dt>
+          _{MsgRatingBy}
+        <dd>
+          #{display userDisplayName}
+      $maybe time <- submissionRatingTime'
+        <dt>
+          _{MsgRatingTime}
+        <dd>
+          #{time}
+      $maybe points <- submissionRatingPoints
+        $case sheetType
+          $of Bonus{..}
+            <dt>
+              _{MsgAchievedBonusPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Normal{..}
+            <dt>
+              _{MsgAchievedNormalPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Pass{..}
+            <dt>
+              _{MsgPassedResult}
+            <dd>
+              $if points >= passingPoints
+                _{MsgPassed}
+              $else
+                _{MsgNotPassed}
+            <dt>
+              _{MsgAchievedPassPoints}
+            <dd>
+              _{MsgPassAchievedOf points passingPoints maxPoints}
+          $of NotGraded
+      $maybe comment <- submissionRatingComment
+        <dt>
+          _{MsgRatingComment}
+        <dd .comment>
+          #{comment}
+    ^{editNotifications}

templates/mail/submissionRated.txt

@@ -0,0 +1 @@
+#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}

templates/mail/support.hamlet

@@ -0,0 +1,29 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <dl>
+      $case userInfo
+        $of Left (Just email)
+          <dt> E-Mail
+          <dd> #{email}
+        $of Left  Nothing
+        $of Right Nothing
+          <dt> Ungültige UserId erhalten!
+        $of Right (Just (Entity _ User{..}))
+          <dt> Name
+          <dd> #{userDisplayName}
+          <dt> E-Mail
+          <dd> #{userEmail}
+          $maybe matrnr <- userMatrikelnummer
+            <dt> Matrikelnummer
+            <dd> #{matrnr}
+          <dt> E-Mail Sprachen
+          $forall lang <- mailLanguages userMailLanguages
+            <dd> #{lang}
+      <dt> Zeit
+      <dd> #{rtime}
+    <p style="white-space: pre">
+      #{jHelpRequest}

templates/messages/submissionCreateDuplicates.hamlet

@@ -0,0 +1,6 @@
+_{MsgSheetDuplicatePseudonym}
+
+<ul>
+  $forall p <- duplicate
+    <li .pseudonym>
+      #{review pseudonymText p}

templates/messages/submissionCreateExisting.hamlet

@@ -0,0 +1,9 @@
+_{MsgSheetCreateExisting}
+
+<dl>
+  $forall (subId, pseudos) <- subs
+    <dt>#{toPathPiece subId}
+    <dd>
+      <ul>
+        $forall p <- pseudos
+          <li .pseudonym>#{review pseudonymText p}

templates/messages/systemMessagesDeleted.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesDeleted}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/messages/systemMessagesSetFrom.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesActivated}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/messages/systemMessagesSetTo.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesDeactivated}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/profile.hamlet

@@ -1,62 +1,2 @@
 <div .profile>
-
-  <dl .deflist.profile-dl>
-      <dt .deflist__dt> _{MsgName}
-      <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
-      $maybe matnr <- userMatrikelnummer
-        <dt .deflist__dt> _{MsgMatrikelNr}
-        <dd .deflist__dd> #{matnr}
-      <dt .deflist__dt> _{MsgEMail}
-      <dd .deflist__dd> #{display userEmail}
-      <dt .deflist__dt> _{MsgIdent}
-      <dd .deflist__dd> #{display userIdent}
-    $if not $ null admin_rights
-      <dt .deflist__dt> Administrator
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value institute) <- admin_rights
-            <li .list-ul__item>
-              <a href=@{SchoolShowR $ SchoolKey institute}>
-                #{display institute}
-    $if not $ null lecturer_rights
-      <dt .deflist__dt> Lehrberechtigt
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value institute) <- lecturer_rights
-            <li .list-ul__item>
-              <a href=@{SchoolShowR $ SchoolKey institute}>
-                #{display institute}
-    $if not $ null lecture_corrector
-      <dt .deflist__dt> Korrektor
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
-            <li .list-ul__item>
-              <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
-    $if not $ null studies
-      <dt .deflist__dt> Studiengänge
-      <dd .deflist__dd>
-        <div .scrolltable>
-          <table .table.table--striped.table--hover.table--condensed>
-            <tr .table__row>
-              <th .table__th> Abschluss
-              <th .table__th> Studiengang
-              <th .table__th> Studienart
-              <th .table__th> Semester
-
-            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
-              <tr.table__row>
-                <td .table__td>
-                  $maybe name <- E.unValue degree
-                    #{display name}
-                  $nothing
-                    #{display degreeKey}
-                <td .table__td>
-                  $maybe name <- E.unValue field
-                    #{display name}
-                  $nothing
-                    #{display fieldKey}
-                <td .table__td>_{E.unValue fieldtype}
-                <td .table__td>#{display semester}
-
   ^{settingsForm}

templates/profileData.hamlet

@@ -1,9 +1,70 @@
-<div .container>
+<div .profile>
-  $if hasRows
+
-    <div .container>
+  <dl .deflist.profile-dl>
-      <h2> Eigene Kurse
+      <dt .deflist__dt> _{MsgName}
+      <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
+      $maybe matnr <- userMatrikelnummer
+        <dt .deflist__dt> _{MsgMatrikelNr}
+        <dd .deflist__dd> #{matnr}
+      <dt .deflist__dt> _{MsgEMail}
+      <dd .deflist__dd> #{display userEmail}
+      <dt .deflist__dt> _{MsgIdent}
+      <dd .deflist__dd> #{display userIdent}
+    $if not $ null admin_rights
+      <dt .deflist__dt> Administrator
+      <dd .deflist__dd>
+        <ul .list-ul>
+          $forall (E.Value institute) <- admin_rights
+            <li .list-ul__item>
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
+    $if not $ null lecturer_rights
+      <dt .deflist__dt> Lehrberechtigt
+      <dd .deflist__dd>
+        <ul .list-ul>
+          $forall (E.Value institute) <- lecturer_rights
+            <li .list-ul__item>
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
+    $if not $ null lecture_corrector
+      <dt .deflist__dt> Korrektor
+      <dd .deflist__dd>
+        <ul .list-ul>
+          $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
+            <li .list-ul__item>
+              <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+    $if not $ null studies
+      <dt .deflist__dt> Studiengänge
+      <dd .deflist__dd>
+        <div .scrolltable>
+          <table .table.table--striped.table--hover.table--condensed>
+            <tr .table__row>
+              <th .table__th> Abschluss
+              <th .table__th> Studiengang
+              <th .table__th> Studienart
+              <th .table__th> Semester
+
+            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
+              <tr.table__row>
+                <td .table__td>
+                  $maybe name <- E.unValue degree
+                    #{display name}
+                  $nothing
+                    #{display degreeKey}
+                <td .table__td>
+                  $maybe name <- E.unValue field
+                    #{display name}
+                  $nothing
+                    #{display fieldKey}
+                <td .table__td>_{E.unValue fieldtype}
+                <td .table__td>#{display semester}
+
+  <div .container>
+    $if hasRows
       <div .container>
-        ^{ownedCoursesTable}
+        <h2> Eigene Kurse
+        <div .container>
+          ^{ownedCoursesTable}
 
   <div .container>
     <h2> Kursanmeldungen

templates/sheetShow.hamlet

@@ -1,33 +1,34 @@
-<div .container>
+$newline never
-  $maybe descr <- sheetDescription sheet
+$maybe descr <- sheetDescription sheet
-    <h2 #description>Hinweise
+  <section>
-    <p> #{descr}
+    <h2 #description>_{MsgSheetDescription}
-
-  <h3>Bewertung
-  <p>
-    #{display $ sheetType sheet}
-
-  $maybe marking <- sheetMarkingText sheet
     <p>
-      #{marking}
+      #{descr}
 
-  <p>
+<section>
-    Download und Abgabe freigeschaltet ab
+  <dl .deflist>
-    #{sheetFrom}
+    <dt .deflist__dt>_{MsgSheetActiveFrom}
+    <dd .deflist__dd>#{sheetFrom}
+    <dt .deflist__dt>_{MsgSheetActiveTo}
+    <dd .deflist__dd>#{sheetTo}
+    $maybe hints <- hintsFrom <* guard hasHints
+      <dt .deflist__dt>_{MsgSheetHintFrom}
+      <dd .deflist__dd>#{hints}
+    $maybe solution <- solutionFrom <* guard hasSolution
+      <dt .deflist__dt>_{MsgSheetSolutionFrom}
+      <dd .deflist__dd>#{solution}
+    <dt .deflist__dt>_{MsgSheetType}
+    <dd .deflist__dd>_{sheetType sheet}
+    $if CorrectorSubmissions == sheetSubmissionMode sheet
+      <dt .deflist__dt>_{MsgSheetPseudonym}
+      <dd .deflist__dd #pseudonym>
+        $maybe pseudonym <- mPseudonym
+          <span .pseudonym>#{pseudonym}
+        $nothing
+          <form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
+            ^{generateWidget}
 
-  <p>
+$if hasFiles
-    Abgabe bis
+  <section>
-    #{sheetTo}
+    <h2>_{MsgSheetFiles}
-
+    ^{fileTable}
-  $maybe hints <- hintsFrom <* guard hasHints
-    <p>
-      Hinweise ab
-      #{hints}
-
-  $maybe solution <- solutionFrom <* guard hasSolution
-    <p>
-      Lösung ab
-      #{solution}
-
-  <h2>Dateien
-  ^{fileTable}

templates/standalone/alerts.lucius

@@ -82,6 +82,10 @@
   transition: margin-bottom .2s ease-out;
 }
 
+.alert a {
+  color: var(--color-lightwhite);
+}
+
 @keyframes slide-in-alert {
   from {
     transform: translateY(120%);

templates/standalone/modal.julius

@@ -56,6 +56,7 @@
 
       if (modal.dataset.dynamic === 'True') {
         var dynamicContentURL = trigger.getAttribute('href');
+        console.log(dynamicContentURL);
         if (dynamicContentURL.length > 0) {
           fetch(dynamicContentURL, {
             credentials: 'same-origin',

templates/standalone/modal.lucius

@@ -16,11 +16,13 @@
   overflow: auto;
   opacity: 0;
   transition: all .15s ease;
+  pointer-events: none;
 
   &.modal--open {
     opacity: 1;
     z-index: 200;
     transform: translate(-50%, -50%) scale(1, 1);
+    pointer-events: all;
   }
 }