Merge branch 'master' into course-teaser

.hlint.yaml

@@ -4,6 +4,7 @@
 
   - ignore: { name: "Parse error" }
   - ignore: { name: "Reduce duplication" }
+  - ignore: { name: "Redundant lambda" }
   - ignore: { name: "Use ||" }
   - ignore: { name: "Use &&" }
   - ignore: { name: "Use ++" }

ChangeLog.md

@@ -1,3 +1,9 @@
+  * Version 27.03.2019
+
+    Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen
+
+    Erfassung Studiengangsdaten
+
   * Version 20.03.2019
 
     Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)

FragenSJ.txt

@@ -1,38 +0,0 @@
-** Sicherheitsabfragen?
- - Verschlüsselung des Zugriffs?
-
- - SDelR tid csh sn : GET zeigt Sicherheitsabfrage
-                          POST löscht.
-  Ist das so sinnvoll?
-  Sicherheitsabfrage als PopUpMessage?
-
- - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
-    (Sheet.hs -> fetchSheet)
-
- - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das?
-  Kann man abfragen, was bei deleteCascade alles gelöscht wird?
-
-
-
-** i18n:
- - i18n der
-      Links       -> MenuItems verwenden wie bisher
-      Page Titles -> setTitleI
-      Buttons?    -> Kann leicht geändert werden!
-   Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel?
-
-** Page pageActions  - Berechtigungen prüfen?
- => Eigener Constructor statt NavbarLeft/Right?!
-
-
-** FORMS
- 3 - Sheets: Multiple Files -> wird später gemacht
-   - Versionen für Studenten/Korrektoren/Lecturers/Admins
-     -> ja über isAuthorizedDB siehe unten,
-     -> Lecturer kann gleich auf Edit-Seite gehen wie in UniWorX
-
-
-Freischaltung von Teilen einer Webseite:
- - Freigabe der Links über Authorisierung in der Foundation
- - Anzeige der Links nach Authorisierung wie in menItemAccessCallback
- - möglichst direkt isAuthorizedDB in einem runDB aufrufen!!!

PageActionPrime.txt

@@ -0,0 +1,34 @@
+Übersicht über PageActions und Workflow im Vergleich zum alten UniWorX:
+-----
+
+Course Actions im alten UniWorX:
+- Studenten
+- Übungsgruppen
+- Übungsblätter
+- Klausuren
+- E-Mails
+- Online-Evaluation
+
+-----
+
+CourseActions in Uni2Work:
+-1 Übungsblätter    (öfter)
+[ Auch aus SheetList übernommen un hier ebenfalls angzeigt:
+-1 Aktuelles Blatt  (häufig)
+-1 Letztes unzugewiesenes (häufig, nur Assistenten)
+-1 Abgaben                (häufig, nur Assistenten)
+-1 Korrekturen            (häufig, nur Assistenten)
+-1 Neues Blatt            (häufig, nur Assistenten)
+]
+-2 Teilnehmerliste  (gelegentlich, nur Assistenten)
+-2 Kurs editieren   (selten, nur Assistenten)
+-2 Kurs klonen      (selten, nur Assistenten)
+-2 Kurs löschen     (sehr selten, nur Assistenten/Admins)
+
+SheetList:
+- Aktuelles Blatt
+- Letztes unzugewiesenes
+- Abgaben
+- Korrekturen
+- Neues Blatt
+

build.sh

@@ -1,4 +1,4 @@
 #!/usr/bin/env bash
 
-exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
+exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev
 echo Build task completed.

db.sh

@@ -1,4 +1,4 @@
 #!/usr/bin/env bash
 # Options: see /test/Database.hs (Main)
-stack build --fast --flag uniworx:library-only --flag uniworx:dev
+stack build --fast --flag uniworx:-library-only --flag uniworx:dev
 stack exec uniworxdb -- $@

hlint.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+
+exec -- ./test.sh uniworx:test:hlint

messages/uniworx/de.msg

@@ -1,11 +1,18 @@
+PrintDebugForStupid name@Text: Debug message "#{name}"
+
 BtnSubmit: Senden
 BtnAbort: Abbrechen
 BtnDelete: Löschen
 BtnRegister: Anmelden
 BtnDeregister: Abmelden
 BtnHijack: Sitzung übernehmen
+BtnSave: Speichern
+BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
+BtnCandidatesDeleteConflicts: Konflikte löschen
+BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 
 Aborted: Abgebrochen
+Remarks: Hinweise
 Registered: Angemeldet
 RegisteredHeader: Anmeldung
 RegisteredSince date@Text: Angemeldet seit #{date}
@@ -13,6 +20,11 @@ RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
 DeRegUntil: Abmeldungen bis
 
+GenericKey: Schlüssel
+GenericShort: Kürzel
+GenericIsNew: Neu
+GenericHasConflict: Konflikt
+
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
@@ -34,6 +46,8 @@ TermStartDay: Erster Tag
 TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
 TermEndDay: Letzter Tag
 TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
+TermHolidays: Feiertage
+TermHolidayPlaceholder: Feiertag
 TermLectureStart: Beginn Vorlesungen
 TermLectureEnd: Ende Vorlesungen
 TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.
@@ -51,8 +65,8 @@ CourseCapacity: Kapazität
 CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
 CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
 CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
-CourseRegisterOk: Sie wurden angemeldet
+CourseRegisterOk: Anmeldung erfolgreich
-CourseDeregisterOk: Sie wurden abgemeldet
+CourseDeregisterOk: Erfolgreich abgemeldet
 CourseStudyFeature: Assoziiertes Hauptfach
 CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
 CourseSecretWrong: Falsches Kennwort
@@ -71,8 +85,10 @@ CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
+CourseMemberOf: Teilnehmer
 CourseMembersCount n@Int: #{display n}
 CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max}
+CourseMembersCountOf n@Int mbNum@IntMaybe: #{display n} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"}
 CourseName: Name
 CourseDescription: Beschreibung
 CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@@ -93,6 +109,20 @@ CourseFilterNone: Egal
 CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
 CourseDeleted: Kurs gelöscht
 CourseUserNote: Notiz
+CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
+CourseUserNoteSaved: Notizänderungen gespeichert
+CourseUserNoteDeleted: Teilnehmernotiz gelöscht
+CourseUserDeregister: Abmelden
+CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
+
+CourseLecturers: Kursverwalter
+CourseLecturer: Dozent
+CourseAssistant: Assistent
+CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter mit E-Mail #{email}
+CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen
+CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen
+CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein
+CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@@ -129,21 +159,21 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan
 SheetName: Name
 SheetDescription: Hinweise für Teilnehmer
 SheetGroup: Gruppenabgabe
-SheetVisibleFrom: Sichtbar ab
+SheetVisibleFrom: Sichtbar für Teilnehmer ab
-SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
+SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Fristen/Bewertung sich noch ändern kann
-SheetActiveFrom: Aktiv ab
+SheetActiveFrom: Beginn Abgabezeitraum
-SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
+SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
-SheetActiveTo: Abgabefrist
+SheetActiveTo: Ende Abgabezeitraum
 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
+SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
-SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
+SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
-SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden
+SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
-SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden
+SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
 
 
 Deadline: Abgabe
@@ -214,7 +244,7 @@ AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
 SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
-AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
+AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
 Corrector: Korrektor
 Correctors: Korrektoren
 CorState: Status
@@ -246,11 +276,15 @@ DataProtHeading: Datenschutzerklärung
 SystemMessageHeading: Uni2work Statusmeldung
 SystemMessageListHeading: Uni2work Statusmeldungen
 
+HomeOpenCourses: Kurse mit offener Registrierung
+HomeUpcomingSheets: Anstehende Übungsblätter
+
 NumCourses num@Int64: #{display num} Kurse
 CloseAlert: Schliessen
 
 Name: Name
 MatrikelNr: Matrikelnummer
+NoMatrikelKnown: Keine Matrikelnummer
 Theme: Oberflächen Design
 Favoriten: Anzahl gespeicherter Favoriten
 Plugin: Plugin
@@ -351,6 +385,8 @@ AccessRightsFor: Berechtigungen für
 AdminFor: Administrator
 LecturerFor: Dozent
 LecturersFor: Dozenten
+AssistantFor: Assistent
+AssistantsFor: Assistenten
 ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
@@ -408,17 +444,23 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr
 SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
 
 AdminFeaturesHeading: Studiengänge
+StudyTerms: Studiengänge
+StudyTerm: Studiengang
+NoStudyTermsKnown: Nicht eingeschrieben
 StudyFeatureInference: Studiengangschlüssel-Inferenz
 StudyFeatureAge: Fachsemester
 StudyFeatureDegree: Abschluss
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
 NoPrimaryStudyField: (kein Hauptfach registriert)
+StudyFeatureType:
+StudyFeatureValid: Aktiv
+StudyFeatureUpdate: Abgeglichen
 
-DegreeKey: Schlüssel Abschluss
+DegreeKey: Abschlussschlüssel
 DegreeName: Abschluss
 DegreeShort: Abschlusskürzel
-StudyTermsKey: Schlüssel Studiengang
+StudyTermsKey: Studiengangschlüssel
 StudyTermsName: Studiengang
 StudyTermsShort: Studiengangkürzel
 StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
@@ -428,7 +470,10 @@ AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat
 RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
 CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
 NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
+IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
 StudyTermIsNew: Neu
+StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
 
 MailTestFormEmail: Email-Addresse
 MailTestFormLanguages: Spracheinstellungen
@@ -451,7 +496,7 @@ MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@She
 
 MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
 MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
-MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
+MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen
 MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (display n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (display num <> " Teilnehmern")}.
 
 MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
@@ -465,6 +510,7 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu
 
 MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
+MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@@ -508,7 +554,7 @@ NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übun
 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
+NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen
 NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
 NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
 NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
@@ -539,6 +585,7 @@ HelpAnswer: Antworten an
 HelpUser: Meinen Benutzeraccount
 HelpAnonymous: Keine Antwort (Anonym)
 HelpEmail: E-Mail
+HelpSubject: Betreff
 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.
@@ -683,3 +730,5 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de
 
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
+
+NavigationFavourites: Favoriten

models/courses

@@ -33,6 +33,7 @@ CourseFavourite           -- which user accessed which course when, only display
 Lecturer                       -- course ownership
     user         UserId
     course       CourseId
+    type         LecturerType  default='"lecturer"'
     UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
 CourseParticipant                      -- course enrolement
     course       CourseId
@@ -40,12 +41,20 @@ CourseParticipant                      -- course enrolement
     registration UTCTime               -- time of last enrolement for this course
     field        StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
     UniqueParticipant user course
+-- Replace the last two by the following, once an audit log is available
+-- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
+--     course       CourseId
+--     user         UserId
+--     note         Html          -- arbitrary user-defined text; visible only to lecturer of this course
+--     time         UTCTime       -- PROBLEM: deleted note has no modification date
+--     editor       UserId        -- who edited this note last
+--     UniqueCourseUserNote user course
 CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
     course       CourseId
     user         UserId
-    note         Text          -- arbitrary user-defined text; visible only to lecturer of this course
+    note         Html          -- arbitrary user-defined text; visible only to lecturer of this course
-    UniqueCourseUserNotes user course
+    UniqueCourseUserNote user course
-CourseUserNoteEdit             -- who edited a participants course note whenl
+CourseUserNoteEdit             -- who edited a participants course note when
     user         UserId
     time         UTCTime
-    note         CourseUserNoteId
+    note         CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more

package.yaml

@@ -116,6 +116,7 @@ dependencies:
   - lifted-base
   - lattices
   - hsass
+  - semigroupoids
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -217,6 +218,9 @@ executables:
     dependencies:
       - uniworx
     other-modules: []
+    when:
+      - condition: flag(library-only)
+        buildable: false
 
 # Test suite
 tests:

routes

@@ -36,7 +36,8 @@
 
 /                             HomeR             GET           !free
 /users                        UsersR            GET           -- no tags, i.e. admins only
-/users/#CryptoUUIDUser        AdminUserR        GET POST      !development
+/users/#CryptoUUIDUser        AdminUserR        GET POST
+/users/#CryptoUUIDUser/delete AdminUserDeleteR      POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
 /admin                        AdminR            GET
 /admin/features               AdminFeaturesR    GET POST
@@ -52,13 +53,13 @@
 /help                         HelpR             GET POST       !free
 
 /user                      ProfileR          GET POST        !free
-/user/profile              ProfileDataR      GET POST        !free
+/user/profile              ProfileDataR      GET             !free
 /user/authpreds            AuthPredsR        GET POST        !free
 
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
 /term/edit                 TermEditR         GET POST
-/term/#TermId/edit         TermEditExistR    GET
+/term/#TermId/edit         TermEditExistR    GET POST
 !/term/#TermId             TermCourseListR   GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET        !free
 
@@ -74,8 +75,8 @@
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
-  /users                      CUsersR         GET
+  /users                      CUsersR         GET POST
-  /users/#CryptoUUIDUser      CUserR          GET             !lecturerANDparticipant
+  /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
   /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST

shell.nix

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

src/Application.hs

@@ -76,6 +76,8 @@ import qualified Database.Memcached.Binary.IO as Memcached
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
 import Handler.Home
+import Handler.Info
+import Handler.Help
 import Handler.Profile
 import Handler.Users
 import Handler.Admin

src/Auth/LDAP.hs

@@ -6,7 +6,7 @@ module Auth.LDAP
   , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
   ) where
 
-import Import.NoFoundation
+import Import.NoFoundation hiding (userEmail, userDisplayName)
 import Control.Lens
 import Network.Connection
 
@@ -39,9 +39,16 @@ data CampusMessage = MsgCampusIdentNote
 
 
 findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
-findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
+findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
   where
-    userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
+    userFilters =
+      [ userPrincipalName Ldap.:= Text.encodeUtf8 ident
+      , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , userEmail         Ldap.:= Text.encodeUtf8 ident
+      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
+      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , userDisplayName   Ldap.:= Text.encodeUtf8 ident
+      ]
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
       , Ldap.size 2
@@ -49,17 +56,18 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
       , Ldap.derefAliases Ldap.DerefAlways
       ]
 
-userPrincipalName :: Ldap.Attr
+userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
 userPrincipalName = Ldap.Attr "userPrincipalName"
+userEmail         = Ldap.Attr "mail"
+userDisplayName   = Ldap.Attr "displayName"
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , Button site ButtonSubmit
               ) => AForm (HandlerT site IO) CampusLogin
 campusForm = CampusLogin
-  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
+  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
   <*> areq passwordField (fslI MsgCampusPassword) Nothing
-  <*  submitButton
 
 campusLogin :: forall site.
                ( YesodAuth site
@@ -80,9 +88,14 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
         FormMissing -> redirect LoginR
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
           ldapResult <- withLdap pool $ \ldap -> do
-            Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
             Ldap.bind ldap ldapDn ldapPassword
-            findUser conf ldap campusIdent [userPrincipalName]
+            searchResults <- findUser conf ldap campusIdent [userPrincipalName]
+            case searchResults of
+              [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] 
+                | Just [principalName] <- lookup userPrincipalName userAttrs
+                , Right credsIdent <- Text.decodeUtf8' principalName
+                -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
+              other -> return $ Left other
           case ldapResult of
             Left err
               | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
@@ -92,16 +105,11 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
               | otherwise -> do
                   $logErrorS "LDAP" $ "Error during login: " <> tshow err
                   loginErrorMessageI LoginR Msg.AuthError
-            Right searchResults
+            Right (Right (userDN, credsIdent)) ->
-              | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
+              lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
-              , Just [principalName] <- lookup userPrincipalName userAttrs
+            Right (Left searchResults) -> do
-              , Right credsIdent <- Text.decodeUtf8' principalName
+              $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
-                -> do
+              loginErrorMessageI LoginR Msg.AuthError
-                  $logDebugS "LDAP" $ tshow searchResults
-                  lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
-              | otherwise -> do
-                  $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
-                  loginErrorMessageI LoginR Msg.AuthError
     apDispatch _ _ = notFound
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm

src/Data/List/NonEmpty/Instances.hs

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

src/Database/Esqueleto/Utils.hs

@@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
   , isInfixOf, hasInfix
   , any, all
   , SqlIn(..)
-  , mkExactFilter, mkContainsFilter
+  , mkExactFilter, mkExactFilterWith
-  , anyFilter
+  , mkContainsFilter
+  , anyFilter, allFilter
   ) where
 
 import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
@@ -54,26 +55,42 @@ all :: Foldable f =>
 all test = F.foldr (\needle acc -> acc E.&&. test needle) true
 
 
-
 -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
 $(sqlInTuples [2..16])
 
+-- | Example for usage of unValueN
+_exampleUnValueN :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
+_exampleUnValueN = $(unValueN 3)
+
+-- | Example for usage of unValueNIs
+_exampleUnValueNIs :: (E.Value a, b, E.Value c) -> (a,b,c)
+_exampleUnValueNIs = $(unValueNIs 3 [1,3])
+
 -- | Example for usage of sqlIJproj
--- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
+_queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
--- queryFeaturesDegree  = $(sqlIJproj 3 2)
+_queryFeaturesDegree  = $(sqlIJproj 3 2)
 
 
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter for exact matches in a collection
 --   (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
 mkExactFilter :: (PersistField a)
-  =>  (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
+  => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
   -> t                             -- ^ query row
   -> Set.Set a                     -- ^ needle collection
   -> E.SqlExpr (E.Value Bool)
-mkExactFilter lenslike row criterias
+mkExactFilter = mkExactFilterWith id
+
+-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
+mkExactFilterWith :: (PersistField b)
+  => (a -> b)                      -- ^ type conversion
+  -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
+  -> t                             -- ^ query row
+  -> Set.Set a                     -- ^ needle collection
+  -> E.SqlExpr (E.Value Bool)
+mkExactFilterWith cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
+  | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
 
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
@@ -87,9 +104,22 @@ mkContainsFilter lenslike row criterias
   | Set.null criterias = true
   | otherwise = any (hasInfix $ lenslike row) criterias
 
-
+-- | Combine several filters, using logical or
-anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+anyFilter :: (Foldable f)
-                   -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
+  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+  -> t
+  -> Set.Set Text
+  -> E.SqlExpr (E.Value Bool)
 anyFilter fltrs needle criterias = F.foldr aux false fltrs
   where
-    aux fltr acc = fltr needle criterias E.||. acc
+    aux fltr acc = fltr needle criterias E.||. acc
+
+-- | Combine several filters, using logical and
+allFilter :: (Foldable f)
+  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+  -> t
+  -> Set.Set Text
+  -> E.SqlExpr (E.Value Bool)
+allFilter fltrs needle criterias = F.foldr aux true fltrs
+  where
+    aux fltr acc = fltr needle criterias E.&&. acc

src/Database/Esqueleto/Utils/TH.hs

@@ -1,6 +1,7 @@
 module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
+  , unValueN, unValueNIs
   , sqlIJproj, sqlLOJproj
   ) where
 
@@ -48,6 +49,30 @@ sqlInTuple arity = do
       ]
     ]
 
+-- | Generic unValuing of Tuples of Values, i.e.
+--   $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
+unValueN :: Int -> ExpQ
+unValueN arity = do
+    vs <- replicateM arity $ newName "v"
+    let pat = tupP $ map varP vs
+    let uvE v = [e|E.unValue $(varE v)|]
+    let rhs = tupE $ map uvE vs
+    lam1E pat rhs
+
+-- | Generic unValuing of certain indices of a Tuple, i.e.
+--   $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
+unValueNIs :: Int -> [Int] -> ExpQ
+unValueNIs arity uvIdx = do
+    vs <- replicateM arity $ newName "v"
+    let pat = tupP $ map varP vs
+    let rhs = tupE $ zipWith (curry uvEi) vs [1 ..]
+    lam1E pat rhs
+  where
+    uvEi (v,i) | i `elem` uvIdx = [e|E.unValue $(varE v)|]
+               | otherwise      = varE v
+
+
+
 -- | Generic projections for InnerJoin-tuples
 --   gives I-th element of N-tuple of left-associative InnerJoin-pairs,
 --   i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)

src/Foundation.hs

@@ -26,8 +26,10 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.CryptoID as E
 
 import Data.ByteArray (convert)
-import Crypto.Hash (Digest, SHAKE256)
+import Crypto.Hash (Digest, SHAKE256, SHAKE128)
 import Crypto.Hash.Conduit (sinkHash)
+import qualified Data.UUID as UUID
+import qualified Data.Binary as Binary
 
 import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
@@ -62,7 +64,6 @@ import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
 import qualified Control.Monad.Catch as C
 
 import Handler.Utils.StudyFeatures
-import Handler.Utils.Templates
 import Utils.Lens
 import Utils.Form
 import Utils.Sheet
@@ -172,7 +173,13 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
+-- Convenience Type for Messages
+type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers
 
+-- | Convenience function for i18n messages definitions
+maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text  -> Text
+maybeDisplay _      Nothing  _     = mempty
+maybeDisplay before (Just x) after = before <> (display x) <> after
 
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage "UniWorX" "messages/uniworx" "de"
@@ -233,6 +240,7 @@ embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
 embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
+embedRenderMessage ''UniWorX ''LecturerType id
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -993,15 +1001,15 @@ siteLayout' headingOverride widget = do
     | isModal -> getMessages
     | otherwise -> do
         applySystemMessages
-        authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
+        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
         forM_ authTagPivots $
           \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
         getMessages
 
   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 (urlRoute . menuItemRoute . view _1) menuTypes
+                      navItems = map (view _2) favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
-                      highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
+                      highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
                   in \r -> Just r == highR
       favouriteTerms :: [TermIdentifier]
       favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
@@ -1014,6 +1022,17 @@ siteLayout' headingOverride widget = do
       -- value passed to hamletToRepHtml cannot be a widget, this allows
       -- you to use normal widget features in default-layout.
 
+      navbarModal (MenuItem{..}, menuIdent') = customModal Modal
+        { modalTriggerId = Just menuIdent'
+        , modalId = Nothing
+        , modalTrigger = \(Just route) menuIdent -> $(widgetFile "widgets/navbar/item")
+        , modalContent = Left menuItemRoute
+        }
+
+      navbarItem (MenuItem{..}, menuIdent) = do
+        route <- toTextUrl menuItemRoute
+        $(widgetFile "widgets/navbar/item")
+
       navbar :: Widget
       navbar = $(widgetFile "widgets/navbar/navbar")
       asidenav :: Widget
@@ -1141,7 +1160,7 @@ instance YesodBreadcrumbs UniWorX where
   --         (CourseR tid ssh csh CRegisterR) -- is POST only
   breadcrumb (CourseR tid ssh csh CEditR)     = return ("Editieren"  , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
-  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CShowR)
+  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
@@ -1355,6 +1374,14 @@ pageActions (AdminR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMessageList
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute MessageListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgErrMsgHeading
@@ -2105,7 +2132,6 @@ instance YesodAuth UniWorX where
                           [ UserLastAuthentication =. Just now | not isDummy ]
 
           userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
-          studyTermCandidateIncidence <- liftIO getRandom
 
           let
             userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
@@ -2126,11 +2152,27 @@ instance YesodAuth UniWorX where
           fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
 
           let
-            studyTermCandidates = do
+            studyTermCandidates = Set.fromList $ do
-              studyTermCandidateName <- termNames
+              name <- termNames
-              StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs
+              StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
-              return StudyTermCandidate{..}
+              return (key, name)
-          lift $ insertMany_ studyTermCandidates
+            studyTermCandidateIncidence
+              = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
+              . UUID.fromByteString
+              . fromStrict
+              . (convert :: Digest (SHAKE128 128) -> ByteString)
+              . runIdentity
+              $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
+
+          [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
+            E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
+
+          unless candidatesRecorded $ do
+            let
+              studyTermCandidates' = do
+                (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
+                return StudyTermCandidate{..}
+            lift $ insertMany_ studyTermCandidates'
 
           lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
           forM_ fs $ \f@StudyFeatures{..} -> do
@@ -2179,12 +2221,9 @@ instance YesodMail UniWorX where
   mailT ctx mail = defMailT ctx $ do
     void setMailObjectId
     setDateCurrent
-    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
 
-    ret <- mail
+    mail <* setMailSmtpData
-
-    setMailSmtpData
-    return ret
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

src/Handler/Admin.hs

@@ -170,11 +170,11 @@ postAdminTestR = do
               -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
               -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
               -> FieldView UniWorX -- ^ Submit-Button for this add-widget
-              -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell
+              -> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
     mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
       (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
       let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
-          addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required
+          addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
       return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
     mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
 
@@ -199,9 +199,13 @@ postAdminTestR = do
     -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
     allowAdd :: ListPosition -> Natural -> ListLength -> Bool
     allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
+    -- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
+    buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
 
   -- The actual call to @massInput@ is comparatively simple:
-  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing
+
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
 
 
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
@@ -265,46 +269,71 @@ postAdminErrMsgR = do
 
 
 -- BEGIN - Buttons needed only for StudyTermCandidateManagement
-data ButtonInferStudyTerms = ButtonInferStudyTerms
+data ButtonAdminStudyTerms
+  = BtnCandidatesInfer
+  | BtnCandidatesDeleteConflicts
+  | BtnCandidatesDeleteAll
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonInferStudyTerms
+instance Universe ButtonAdminStudyTerms
-instance Finite ButtonInferStudyTerms
+instance Finite ButtonAdminStudyTerms
 
-nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
+nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
 
-instance Button UniWorX ButtonInferStudyTerms where
+instance Button UniWorX ButtonAdminStudyTerms where
-  btnLabel   ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
+  btnClasses BtnCandidatesInfer           = [BCIsButton, BCPrimary]
-  btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
+  btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
+  btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
+sessionKeyNewStudyTerms :: Text
+sessionKeyNewStudyTerms = "key-new-study-terms"
+
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
-    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
+    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
     let btnForm = wrapForm btnWdgt def
           { formAction = Just $ SomeRoute AdminFeaturesR
           , formEncoding = btnEnctype
           , formSubmit = FormNoSubmit
           }
-    (infConflicts,infAccepted) <- case btnResult of
+    infConflicts <- case btnResult of
-      (FormSuccess ButtonInferStudyTerms) -> do
+      FormSuccess BtnCandidatesInfer -> do
-        (infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler
+        (infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
-        unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous
+        unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
-        unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant
+        unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
-        if null infAccepted
+        let newKeys = map (StudyTermsKey' . fst) infAccepted
-          then addMessageI Info    MsgNoCandidatesInferred
+        setSessionJson sessionKeyNewStudyTerms newKeys
-          else addMessageI Success $ MsgCandidatesInferred $ length infAccepted
+        if  | null infAccepted
-        return (infConflicts,infAccepted)
+              -> addMessageI Info      MsgNoCandidatesInferred
-      _other -> (,[]) <$> runDB Candidates.conflicts
+            | otherwise
-    unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n
+               -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
+        return infConflicts
+      FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
+        confs <- Candidates.conflicts
+        incis <- Candidates.getIncidencesFor (entityKey <$> confs)
+        deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
+        addMessageI Success $ MsgIncidencesDeleted $ length incis
+        return []
+      FormSuccess BtnCandidatesDeleteAll -> runDB $ do
+        deleteWhere ([] :: [Filter StudyTermCandidate])
+        addMessageI Success MsgAllIncidencesDeleted
+        Candidates.conflicts
+      _other -> runDB Candidates.conflicts
 
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
-      , ((),candidateTable)) <- runDB $ (,,)
+      , ((), candidateTable)) <- runDB $ (,,)
       <$> mkDegreeTable
-      <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
+      <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+                            (Set.fromList $ map entityKey infConflicts)
       <*> mkCandidateTable
 
+    -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
+    unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
+
     let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
         degreeResult' = degreeResult <&> getDBFormResult
           (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
@@ -344,7 +373,7 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyDegreeKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgDegreeKey)   (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
             , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
             , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
             , dbRow
@@ -358,11 +387,12 @@ postAdminFeaturesR = do
           dbtFilterUI   = mempty
           dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
                               }
-          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+          psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultSorting [SortAscBy "key"]
       in dbTable psValidator DBTable{..}
 
-    mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
+    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
-    mkStudytermsTable newKeys =
+    mkStudytermsTable newKeys badKeys =
       let dbtIdent      = "admin-studyterms" :: Text
           dbtStyle      = def
           dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
@@ -370,15 +400,18 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyTermsKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgStudyTermsKey)   (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgStudyTermIsNew)  (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
             , dbRow
             ]
           dbtSorting    = Map.fromList
             [ ("key"   , SortColumn (E.^. StudyTermsKey))
-            , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
+            , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))) -- works only once
+            -- Remember: sorting with E.in_ by StudyTermsId instead will produce esqueleto-error "unsafeSqlBinOp: non-id/composite keys not expected here"
+            , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)))
             , ("name"  , SortColumn (E.^. StudyTermsName))
             , ("short" , SortColumn (E.^. StudyTermsShorthand))
             ]
@@ -386,7 +419,9 @@ postAdminFeaturesR = do
           dbtFilterUI   = mempty
           dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
                               }
-          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+          psValidator   = def
+                        -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
       in dbTable psValidator DBTable{..}
 
     mkCandidateTable =

src/Handler/Corrections.hs

@@ -161,6 +161,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
       mkRoute = do
         cid <- encrypt subId
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
+      mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
   in mconcat
      [ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
      , writerCell $ do

src/Handler/Course.hs

@@ -9,15 +9,17 @@ import Utils.Form
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Course
+import Handler.Utils.Form.MassInput
 import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Columns
-import Database.Esqueleto.Utils
+import Database.Persist.Sql (deleteWhereCount)
+import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 -- import Data.Time
--- import qualified Data.Text as T
+import qualified Data.CaseInsensitive as CI
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
@@ -29,6 +31,7 @@ import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
 
+import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@@ -268,7 +271,7 @@ getTermCourseListR tid = do
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do
+  (course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@@ -284,12 +287,17 @@ getCShowR tid ssh csh = do
                   return ( E.countRows :: E.SqlExpr (E.Value Int))
             return (course,school E.^. SchoolName, numParticipants, participant)
     defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
-    lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
+    staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
       E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
       E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
       E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
-      return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
+      return ( lecturer E.^. LecturerType
-    return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers)
+             , user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
+    let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
+        partStaff (CourseLecturer  ,name,surn,mail) = Right (name,surn,mail)
+        partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
+        (assistants,lecturers) = partitionWith  partStaff $ map $(unValueN 4) staff
+    return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants)
 
   mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
   mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
@@ -303,7 +311,7 @@ getCShowR tid ssh csh = do
         }
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
   siteLayout (toWgt $ courseName course) $ do
-    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
+    setTitleI $ prependCourseTitle tid ssh csh (""::Text)
     $(widgetFile "course")
 
 -- | Registration button with maybe a userid if logged in
@@ -370,8 +378,14 @@ getCourseNewR = do
             <*> iopt ciField      "ssh"
             <*> iopt ciField      "csh"
 
+  let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
+      getParams = concat
+        [ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
+        , [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
+        , [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
+        ]
 
-  let noTemplateAction = courseEditHandler Nothing
+  let noTemplateAction = courseEditHandler' Nothing
   case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
     FormMissing      -> noTemplateAction
     FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
@@ -402,7 +416,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = courseToForm oldTemplate in
+            let newTemplate = courseToForm oldTemplate [] in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -420,10 +434,10 @@ getCourseNewR = do
             unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
             when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
             return Nothing
-      courseEditHandler template
+      courseEditHandler' template
 
 postCourseNewR :: Handler Html
-postCourseNewR = courseEditHandler Nothing -- Note: Nothing is safe here, since we will create a new course.
+postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.
 
 getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCEditR  = pgCEditR
@@ -431,10 +445,13 @@ postCEditR = pgCEditR
 
 pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 pgCEditR tid ssh csh = do
-  course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
+  courseLecs <- runDB $ do
+      mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbLecs   <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      return $ (,) <$> mbCourse <*> mbLecs
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler $ courseToForm <$> course
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
 
 
 getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -450,48 +467,50 @@ postCDeleteR tid ssh csh = do
 -- | Course Creation and Editing
 -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
 -- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
-courseEditHandler :: Maybe CourseForm -> Handler Html
+courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
-courseEditHandler mbCourseForm = do
+courseEditHandler miButtonAction mbCourseForm = do
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
-    ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm mbCourseForm
+    ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
-    case result of
+    formResult result $ \case
-      (FormSuccess res@CourseForm
+      res@CourseForm
         { cfCourseId = Nothing
         , cfShort    = csh
         , cfSchool   = ssh
         , cfTerm     = tid
-        }) -> do -- create new course
+        } -> do -- create new course
           now <- liftIO getCurrentTime
-          insertOkay <- runDB $ insertUnique Course
+          insertOkay <- runDB $ do
-            { courseName            = cfName     res
+            insertOkay <- insertUnique Course
-            , courseDescription     = cfDesc     res
+              { courseName            = cfName     res
-            , courseLinkExternal    = cfLink     res
+              , courseDescription     = cfDesc     res
-            , courseShorthand       = cfShort    res
+              , courseLinkExternal    = cfLink     res
-            , courseTerm            = cfTerm     res
+              , courseShorthand       = cfShort    res
-            , courseSchool          = cfSchool   res
+              , courseTerm            = cfTerm     res
-            , courseCapacity        = cfCapacity res
+              , courseSchool          = cfSchool   res
-            , courseRegisterSecret  = cfSecret   res
+              , courseCapacity        = cfCapacity res
-            , courseMaterialFree    = cfMatFree  res
+              , courseRegisterSecret  = cfSecret   res
-            , courseRegisterFrom    = cfRegFrom  res
+              , courseMaterialFree    = cfMatFree  res
-            , courseRegisterTo      = cfRegTo    res
+              , courseRegisterFrom    = cfRegFrom  res
-            , courseDeregisterUntil = cfDeRegUntil res
+              , courseRegisterTo      = cfRegTo    res
-            }
+              , courseDeregisterUntil = cfDeRegUntil res
-          case insertOkay of
+              }
-            (Just cid) -> do
+            whenIsJust insertOkay $ \cid -> do
-              runDB $ do
+                forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
                 insert_ $ CourseEdit aid now cid
-                insert_ $ Lecturer aid cid
+            return insertOkay
+          case insertOkay of
+            Just _ -> do
               addMessageI Info $ MsgCourseNewOk tid ssh csh
               redirect $ TermCourseListR tid
             Nothing ->
               addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
 
-      (FormSuccess res@CourseForm
+      res@CourseForm
         { cfCourseId = Just cid
         , cfShort    = csh
         , cfSchool   = ssh
         , cfTerm     = tid
-        }) -> do -- edit existing course
+        } -> do -- edit existing course
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
           success <- runDB $ do
@@ -516,13 +535,12 @@ courseEditHandler mbCourseForm = do
                 case updOkay of
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
+                    deleteWhere [LecturerCourse ==. cid]
+                    forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
-
-      (FormFailure _) -> addMessageI Warning MsgInvalidInput
-      FormMissing -> return ()
     actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
     defaultLayout $ do
       setTitleI MsgCourseEditTitle
@@ -546,10 +564,11 @@ data CourseForm = CourseForm
         , cfRegFrom    :: Maybe UTCTime
         , cfRegTo      :: Maybe UTCTime
         , cfDeRegUntil :: Maybe UTCTime
+        , cfLecturers  :: [(UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> CourseForm
-courseToForm (Entity cid Course{..}) = CourseForm
+courseToForm (Entity cid Course{..}) lecs = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -563,21 +582,21 @@ courseToForm (Entity cid Course{..}) = CourseForm
     , cfRegFrom    = courseRegisterFrom
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
+    , cfLecturers  = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
     }
 
-makeCourseForm :: Maybe CourseForm -> Form CourseForm
+makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
-makeCourseForm template = identifyForm FIDcourse $ \html -> do
+makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
     -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
     -- let editCid = cfCourseId =<< template -- possible start for refactoring
 
-    mr <- liftHandlerT getMessageRender -- needed for translation of placeholders
+    MsgRenderer mr <- getMsgRenderer
 
-    userSchools <- liftHandlerT . runDB $ do
+    uid <- liftHandlerT requireAuthId
-      userId <- liftHandlerT requireAuthId
+    (lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
-      (fmap concat . sequence)
+      <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
-        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
+      <*> (map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. uid] [] )
-        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
+    let userSchools = lecSchools ++ admSchools
-        ]
 
     termsField <- case template of
           -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@@ -590,6 +609,48 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
                 | otherwise ->  termsSetField [cfTerm cform]
           _allOtherCases -> return termsAllowedField
 
+    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
+        miAdd _ _ nudge btn = Just $ \csrf -> do
+          (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
+          addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
+          let addRes'' = case (,) <$> addRes <*> addRes' of
+                FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
+                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
+                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
+                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
+                FormFailure errs -> FormFailure errs
+                FormMissing -> FormMissing
+              addView'  = toWidget csrf >> fvInput addView >> fvInput btn
+          return (addRes'', addView')
+
+        miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
+        miCell _ lid defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
+          let lrwView' = [whamlet|$newline never
+                  #{csrf}
+                  ^{nameEmailWidget userEmail userDisplayName userSurname} #
+                  ^{fvInput lrwView}
+                |]
+          return (lrwRes,lrwView')
+
+        miDelete :: ListLength   -- ^ Current shape
+                 -> ListPosition -- ^ Coordinate to delete
+                 -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
+        miDelete = miDeleteList
+
+        miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
+        miAllowAdd _ _ _ = True
+
+
+        lecturerForm :: AForm Handler [(UserId,LecturerType)]
+        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
+                MassInput{..}
+                (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
+                True
+                (Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
+                mempty
+
     (newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
         _allIOtherCases -> do
@@ -621,11 +682,11 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
             & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
       <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
             & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
-      <*  submitButton
+      <*> lecturerForm
-    return $ case result of
+    errorMsgs' <- traverse validateCourse result
-      FormSuccess courseResult
+    return $ case errorMsgs' of
-        | errorMsgs <- validateCourse courseResult
+      FormSuccess errorMsgs
-        , not $ null errorMsgs ->
+        | not $ null errorMsgs ->
           (FormFailure errorMsgs,
                 [whamlet|
                   <div class="alert alert-danger">
@@ -640,23 +701,26 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
       _ -> (result, widget)
 
 
-validateCourse :: CourseForm -> [Text]
+validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
-validateCourse CourseForm{..} =
+validateCourse CourseForm{..} = do
-  [ msg | (False, msg) <-
+  uid <- liftHandlerT requireAuthId
-    [
+  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
-      ( NTop cfRegFrom <= NTop cfRegTo
+  MsgRenderer mr <- getMsgRenderer
-      , "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
+
-      )
+  return
-    ,
+    [ mr msg | (False, msg) <-
-      ( NTop cfRegFrom <= NTop cfDeRegUntil
+        [
-      , "Ende des Abmeldezeitraums muss nach dem Anfang liegen"
+          ( NTop cfRegFrom <= NTop cfRegTo
-      )
+          , MsgCourseRegistrationEndMustBeAfterStart
---    No starting date is okay: effective immediately
+          )
---       ( cfHasReg <= (isNothing cfRegFrom)
+        ,
---       , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
+          ( NTop cfRegFrom <= NTop cfDeRegUntil
---       )
+          , MsgCourseDeregistrationEndMustBeAfterStart
---     ,
+          )
-  ] ]
+        , ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+          , MsgCourseUserMustBeLecturer
+          )
+        ] ]
 
 
 
@@ -756,77 +820,131 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell
 colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
-makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
+
-makeCourseUserTable cid colChoices psValidator =
+data CourseUserAction = CourseUserDeregister
-  -- -- psValidator has default sorting and filtering
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-  let dbtIdent     = "courseUsers" :: Text
+
-      dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
+instance Universe CourseUserAction
-      dbtSQLQuery  = userTableQuery cid
+instance Finite CourseUserAction
-      dbtRowKey    = queryUser >>> (E.^. UserId)
+nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
-      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
+embedRenderMessage ''UniWorX ''CourseUserAction id
-      dbtColonnade = colChoices
+
-      dbtSorting   = Map.fromList
+makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
-        [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+makeCourseUserTable cid colChoices psValidator = do
-        , sortUserSurname     queryUser -- needed for initial sorting
+    Just currentRoute <- liftHandlerT getCurrentRoute
-        , sortUserDisplayName queryUser -- needed for initial sorting
+    -- -- psValidator has default sorting and filtering
-        , sortUserEmail       queryUser
+    let dbtIdent     = "courseUsers" :: Text
-        , sortUserMatriclenr  queryUser
+        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
-        , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+        dbtSQLQuery  = userTableQuery cid
-        , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+        dbtRowKey    = queryUser >>> (E.^. UserId)
-        , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
-        , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+        dbtColonnade = colChoices
-        , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+        dbtSorting   = Map.fromList
-        , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
-        , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+          , sortUserSurname     queryUser -- needed for initial sorting
-              E.sub_select . E.from $ \edit -> do
+          , sortUserDisplayName queryUser -- needed for initial sorting
-                E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+          , sortUserEmail       queryUser
-                return . E.max_ $ edit E.^. CourseUserNoteEditTime
+          , sortUserMatriclenr  queryUser
-          )
+          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
-        ]
+          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-      dbtFilter    = Map.fromList
+          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-        [ fltrUserNameLink    queryUser
+          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-        , fltrUserEmail       queryUser
+          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-        , fltrUserMatriclenr  queryUser
+          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
-        , fltrUserNameEmail   queryUser
+          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
-        -- , ("course-user-degree", error "TODO") -- TODO
+                E.sub_select . E.from $ \edit -> do
-        -- , ("course-user-field" , error "TODO") -- TODO
+                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
-        , ("course-user-semesternr", FilterColumn $ mkExactFilter $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
-        -- , ("course-registration", error "TODO") -- TODO
+            )
-        -- , ("course-user-note", error "TODO") -- TODO
+          ]
-        ]
+        dbtFilter    = Map.fromList
-      dbtFilterUI mPrev = mconcat
+          [ fltrUserNameLink    queryUser
-        [ fltrUserNameEmailUI  mPrev
+          , fltrUserEmail       queryUser
-        , fltrUserMatriclenrUI mPrev
+          , fltrUserMatriclenr  queryUser
-        ]
+          , fltrUserNameEmail   queryUser
-      dbtParams    = def
+          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
-  in dbTableWidget' psValidator DBTable{..}
+          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , ("field"       , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsName)
+                                 , E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
+                                 ] )
+          , ("degree"      , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
+                                 , E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
+                                 ] )
+          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+          -- , ("course-registration", error "TODO") -- TODO
+          -- , ("course-user-note", error "TODO") -- TODO
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailUI  mPrev
+          , fltrUserMatriclenrUI mPrev
+          , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
+          , prismAForm (singletonFilter "field")  mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
+          ]
+        dbtParams    = DBParamsForm
+          { dbParamsFormMethod = POST
+          , dbParamsFormAction = Just $ SomeRoute currentRoute
+          , dbParamsFormAttrs  = []
+          , dbParamsFormSubmit = FormSubmit
+          , dbParamsFormAdditional = \csrf -> do
+              (res,vw) <- mreq (selectField optionsFinite) "" Nothing
+              let formWgt = toWidget csrf <> fvInput vw
+                  formRes = (, mempty) . First . Just <$> res
+              return (formRes,formWgt)
+          , dbParamsFormEvaluate = liftHandlerT . runFormPost
+          , dbParamsFormResult   = id
+          , dbParamsFormIdent    = def
+          }
+    over _1 postprocess <$> dbTable psValidator DBTable{..}
+  where
+    postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool  UserTableData) -> FormResult (CourseUserAction, Set UserId)
+    postprocess inp = do
+      (First (Just act), usrMap) <- inp
+      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+      return (act, usrSet)
+
+getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUsersR = postCUsersR
+postCUsersR tid ssh csh = do
+  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
+    let colChoices  = mconcat
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , colUserNameLink (CourseR tid ssh csh . CUserR)
+          , colUserEmail
+          , colUserMatriclenr
+          , colUserDegreeShort
+          , colUserField
+          , colUserSemester
+          , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
+          , colUserComment tid ssh csh
+          ]
+        psValidator = def & defaultSortingByName
+    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    numParticipants <- count [CourseParticipantCourse ==. cid]
+    table <- makeCourseUserTable cid colChoices psValidator
+    return (ent, numParticipants, table)
+  formResult participantRes $ \case
+    (CourseUserDeregister,selectedUsers) -> do
+        nrDel <- runDB $ deleteWhereCount
+          [ CourseParticipantCourse ==. cid
+          , CourseParticipantUser <-. Set.toList selectedUsers
+          ]
+        addMessageI Success $ MsgCourseUsersDeregistered nrDel
+        redirect $ CourseR tid ssh csh CUsersR
+  let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
+      headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
+  siteLayout headingLong $ do
+    setTitleI headingShort
+    $(widgetFile "course-participants")
 
 
-getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
-getCUsersR tid ssh csh = do
+getCUserR = postCUserR
-  Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
+postCUserR tid ssh csh uCId = do
-  let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
-      colChoices  = mconcat
-        [ colUserNameLink (CourseR tid ssh csh . CUserR)
-        , colUserEmail
-        , colUserMatriclenr
-        , colUserDegreeShort
-        , colUserField
-        , colUserSemester
-        , sortable (Just "course-registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
-        , colUserComment tid ssh csh
-        ]
-      psValidator = def & defaultSortingByName
-  tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
-  siteLayout heading $ do
-    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-    -- TODO: create hamlet wrapper
-    tableWidget
-
-
-
-getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
-getCUserR _tid _ssh _csh uCId = do
   -- Has authorization checks (OR):
   --
   --   - User is current member of course
@@ -836,18 +954,88 @@ getCUserR _tid _ssh _csh uCId = do
   --   - User is corrector for course
   --   - User is a tutor for course
   --   - User is a lecturer for course
+  let currentRoute = CourseR tid ssh csh (CUserR uCId)
+  dozentId <- requireAuthId
   uid <- decrypt uCId
-  User{..} <- runDB $ get404 uid
+  -- DB reads
-  -- USE src/utils/Form.formResult
+  (cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do
-  defaultLayout -- TODO
+    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    [whamlet|
+    -- Abfrage Benutzerdaten
-      <p>^{nameWidget userDisplayName userSurname}
+    user <- get404 uid
-    |]
+    registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid)
+    -- Abfrage Teilnehmernotiz
+    let thisUniqueNote = UniqueCourseUserNote uid cid
+    mbNoteEnt <- getBy thisUniqueNote
+    (noteText,noteEdits) <- case mbNoteEnt of
+      Nothing -> return (Nothing,[])
+      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
+        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
+          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
+          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
+          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
+          E.limit 1 -- more will be shown, if changed here
+          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
+        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
+    -- Abfrage Studiengänge
+    studies <- 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  (studyfeat, studydegree, studyterms)
+
+    return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies)
+  let editByWgt = [whamlet|
+          $forall (etime,_eemail,ename,_esurname) <- noteEdits
+            <br>
+            _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
+        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
+
+  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
+      aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
+      <*  saveButton
+  formResult noteRes $ \mbNote -> (do
+    now <- liftIO getCurrentTime
+    case mbNote of
+      Nothing -> do
+        runDB $ do
+          -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
+          maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
+          deleteBy thisUniqueNote
+        addMessageI Info MsgCourseUserNoteDeleted
+        redirect currentRoute -- reload page after post
+      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes
+      (Just note) -> do
+        runDB $ do
+          (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
+          void . insert $ CourseUserNoteEdit dozentId now noteKey
+        addMessageI Success MsgCourseUserNoteSaved
+        redirect currentRoute -- reload page after post
+    )
+  -- De-/Register Button for Lecturer
+  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
+  ((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret
+  formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification
+      | isJust registration -> do
+          runDB $ deleteBy $ UniqueParticipant uid cid
+          addMessageI Info MsgCourseDeregisterOk
+      | otherwise -> do
+          actTime <- liftIO getCurrentTime
+          regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId
+          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
+  -- generate output
+  let headingLong  = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
+      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
+  siteLayout headingLong $ do
+    setTitleI headingShort
+    $(widgetFile "course-user")
+
 
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCHiWisR = error "CHiWisR: Not implemented"
 
 getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
-getCNotesR = error "CNotesR: Not implemented"
+-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
+-- If they are shared, adjust MsgCourseUserNoteTooltip
+getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"

src/Handler/Help.hs

@@ -0,0 +1,70 @@
+module Handler.Help where
+
+import Import
+import Handler.Utils
+import Jobs
+
+import qualified Data.Map as Map
+
+data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+instance Universe HelpIdentOptions
+instance Finite HelpIdentOptions
+
+nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
+embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
+
+data HelpForm = HelpForm
+  { hfReferer :: Maybe (Route UniWorX)
+  , hfUserId  :: Either (Maybe Address) UserId
+  , hfSubject :: Maybe Text
+  , hfRequest :: Text
+  }
+
+helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
+helpForm mr mReferer mUid = HelpForm
+    <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
+    <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
+    <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
+    <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing)
+  where
+    identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
+    identActions = Map.fromList $ case mUid of
+      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+      Nothing    -> defaultActions
+
+    defaultActions =
+      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
+      , (HIAnonymous, pure $ Left Nothing)
+      ]
+
+getHelpR, postHelpR :: Handler Html
+getHelpR = postHelpR
+postHelpR = do
+  mUid <- maybeAuthId
+  mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
+  isModal <- hasCustomHeader HeaderIsModal
+  MsgRenderer mr <- getMsgRenderer
+
+  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
+
+  formResultModal res HelpR $ \HelpForm{..} -> do
+    now <- liftIO getCurrentTime
+    hfReferer' <- traverse toTextUrl hfReferer
+    queueJob' JobHelpRequest
+      { jSender      = hfUserId
+      , jHelpSubject = hfSubject
+      , jHelpRequest = hfRequest
+      , jRequestTime = now
+      , jReferer     = hfReferer'
+      }
+    tell . pure =<< messageI Success MsgHelpSent
+
+  defaultLayout $ do
+    setTitleI MsgHelpTitle
+    wrapForm $(widgetFile "help") def
+      { formAction = Just $ SomeRoute HelpR
+      , formEncoding = formEnctype
+      , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+      }

src/Handler/Home.hs

@@ -4,23 +4,20 @@ import Import
 import Handler.Utils
 
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 
-import Jobs
-import Development.GitRev
-
 
 getHomeR :: Handler Html
 getHomeR = do
   muid <- maybeAuthId
-  case muid of
+  defaultLayout $ do
-    Nothing   -> homeAnonymous
+    setTitleI MsgHomeHeading
-    Just uid  -> homeUser uid
+    maybe mempty homeUpcomingSheets muid
+    homeOpenCourses
 
 
-homeAnonymous :: Handler Html
+homeOpenCourses :: Widget
-homeAnonymous = do
+homeOpenCourses = do
   cTime <- liftIO getCurrentTime
   let tableData :: E.SqlExpr (Entity Course)
                   -> E.SqlQuery (E.SqlExpr (Entity Course))
@@ -47,7 +44,7 @@ homeAnonymous = do
         , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
-  courseTable <- runDB $ dbTableWidget' def DBTable
+  courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable
     { dbtSQLQuery  = tableData
     , dbtRowKey    = (E.^. CourseId)
     , dbtColonnade = colonnade
@@ -75,16 +72,12 @@ homeAnonymous = do
     , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtParams    = def
-    , dbtIdent     = "upcomingdeadlines" :: Text
+    , dbtIdent     = "open-courses" :: Text
     }
-  -- let features = $(widgetFile "featureList")
+  $(widgetFile "home/openCourses")
-  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
-  defaultLayout
-    -- (widgetFile "dsgvDisclaimer")
-    $(widgetFile "home")
 
-homeUser :: Key User -> Handler Html
+homeUpcomingSheets :: UserId -> Widget
-homeUser uid = do
+homeUpcomingSheets uid = do
   cTime <- liftIO getCurrentTime
   let tableData :: E.LeftOuterJoin
                         (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
@@ -140,7 +133,7 @@ homeUser uid = do
                                         (toWidget $ hasTickmark True)
         ]
   let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
-  sheetTable <- runDB $ dbTableWidget' validator DBTable
+  sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
     , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
@@ -175,155 +168,6 @@ homeUser uid = do
     , dbtFilterUI  = mempty
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtParams    = def
-    , dbtIdent     = "upcomingdeadlines" :: Text
+    , dbtIdent     = "upcoming-sheets" :: Text
     }
-  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  $(widgetFile "home/upcomingSheets")
-  defaultLayout $
-    -- setTitle "Willkommen zum Uni2work Test!"
-    $(widgetFile "homeUser")
-    -- (widgetFile "dsgvDisclaimer")
-
--- | Versionsgeschichte
-getVersionR :: Handler TypedContent
-getVersionR = getInfoR -- TODO
-
--- | Impressum
-getImpressumR :: Handler Html
-getImpressumR = -- do
-  siteLayoutMsg' MsgMenuImpressum $ do
-    setTitleI MsgImpressumHeading
-    $(i18nWidgetFile "imprint")
-
-
--- | Hinweise zu Datenschutz und Aufbewahrungspflichten
-getDataProtR :: Handler Html
-getDataProtR = -- do
-  siteLayoutMsg' MsgMenuDataProt $ do
-    setTitleI MsgDataProtHeading
-    $(i18nWidgetFile "data-protection")
-
-
--- | Allgemeine Informationen
-getInfoR :: Handler TypedContent
-getInfoR = selectRep $ do
-    let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
-    provideRep . siteLayout infoHeading $ do
-      let features = $(widgetFile "featureList")
-          gitInfo :: Text
-          gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"
-      changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
-      $(widgetFile "versionHistory")
-    provideRep $
-      return ($gitDescribe :: Text)
-
-
-
-
-data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
-  deriving (Eq, Ord, Bounded, Enum, Show, Read)
-
-instance Universe HelpIdentOptions
-instance Finite HelpIdentOptions
-
-nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
-embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
-
-data HelpForm = HelpForm
-  { hfReferer:: Maybe (Route UniWorX)
-  , hfUserId :: Either (Maybe Address) UserId
-  , hfRequest:: Text
-  }
-
-helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
-helpForm mReferer mUid = HelpForm
-    <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
-    <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
-    <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
-  where
-    identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
-    identActions = Map.fromList $ case mUid of
-      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
-      Nothing    -> defaultActions
-
-    defaultActions =
-      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
-      , (HIAnonymous, pure $ Left Nothing)
-      ]
-
-getHelpR, postHelpR :: Handler Html
-getHelpR = postHelpR
-postHelpR = do
-  mUid <- maybeAuthId
-  mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
-  isModal <- hasCustomHeader HeaderIsModal
-
-  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
-  let form = wrapForm formWidget def
-        { formAction = Just $ SomeRoute HelpR
-        , formEncoding = formEnctype
-        , formAttrs = [ ("data-ajax-submit", "") | isModal ]
-        }
-
-  formResultModal res HelpR $ \HelpForm{..} -> do
-    now <- liftIO getCurrentTime
-    hfReferer' <- traverse toTextUrl hfReferer
-    queueJob' JobHelpRequest
-      { jSender      = hfUserId
-      , jHelpRequest = hfRequest
-      , jRequestTime = now
-      , jReferer     = hfReferer'
-      }
-    tell . pure =<< messageI Success MsgHelpSent
-
-  defaultLayout $ do
-    setTitleI MsgHelpTitle
-    $(widgetFile "help")
-
-
-getInfoLecturerR :: Handler Html
-getInfoLecturerR =
-  siteLayoutMsg' MsgInfoLecturerTitle $ do
-    setTitleI MsgInfoLecturerTitle
-    $(i18nWidgetFile "info-lecturer")
-
-
-getAuthPredsR, postAuthPredsR :: Handler Html
-getAuthPredsR = postAuthPredsR
-postAuthPredsR = do
-  (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
-
-  let
-    blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
-    taForm authTag
-      | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
-      | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
-
-  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
-    $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
-
-  mReferer <- runMaybeT $ do
-    param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
-    MaybeT . return $ fromPathPiece param
-
-  let authActiveForm = wrapForm authActiveWidget' def
-        { formAction = Just $ SomeRoute AuthPredsR
-        , formEncoding = authActiveEnctype
-        , formSubmit = FormDualSubmit
-        }
-      authActiveWidget'
-        = [whamlet|
-            $newline never
-            $maybe referer <- mReferer
-              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
-            ^{authActiveWidget}
-          |]
-
-  formResult authActiveRes $ \authTagActive -> do
-    setSessionJson SessionActiveAuthTags authTagActive
-    modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
-    addMessageI Success MsgAuthPredsActiveChanged
-    redirect $ fromMaybe AuthPredsR mReferer
-
-  siteLayoutMsg MsgAuthPredsActive $ do
-    setTitleI MsgAuthPredsActive
-    $(widgetFile "authpreds")

src/Handler/Info.hs

@@ -0,0 +1,48 @@
+module Handler.Info where
+
+import Import
+import Handler.Utils
+
+import Development.GitRev
+
+-- | Versionsgeschichte
+getVersionR :: Handler TypedContent
+getVersionR = selectRep $ do
+  provideRep $
+    return ($gitDescribe :: Text)
+  provideRep getInfoR
+
+-- | Impressum
+getImpressumR :: Handler Html
+getImpressumR = -- do
+  siteLayoutMsg' MsgMenuImpressum $ do
+    setTitleI MsgImpressumHeading
+    $(i18nWidgetFile "imprint")
+
+
+-- | Hinweise zu Datenschutz und Aufbewahrungspflichten
+getDataProtR :: Handler Html
+getDataProtR = -- do
+  siteLayoutMsg' MsgMenuDataProt $ do
+    setTitleI MsgDataProtHeading
+    $(i18nWidgetFile "data-protection")
+
+
+-- | Allgemeine Informationen
+getInfoR :: Handler Html
+getInfoR = do
+  let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
+  siteLayout infoHeading $ do
+    let features = $(widgetFile "featureList")
+        gitInfo :: Text
+        gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"
+    changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
+    $(widgetFile "versionHistory")
+
+  
+getInfoLecturerR :: Handler Html
+getInfoLecturerR =
+  siteLayoutMsg' MsgInfoLecturerTitle $ do
+    setTitleI MsgInfoLecturerTitle
+    $(i18nWidgetFile "info-lecturer")
+

src/Handler/Profile.hs

@@ -10,7 +10,7 @@ import Utils.Lens
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
 import qualified Data.Map as Map
--- import qualified Data.Set as Set
+import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
 
@@ -121,139 +121,47 @@ postProfileR = do
       , formEncoding = formEnctype
       }
 
-postProfileDataR  :: Handler Html
-postProfileDataR = do
-  ((btnResult,_), _) <- runFormPost buttonForm
-  case btnResult of
-    (FormSuccess BtnDelete) -> do
-      (uid, User{..}) <- requireAuthPair
-      clearCreds False -- Logout-User
-      ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
-      -- addMessageIHamlet
-      $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-      -- addMessageI Success $ MsgDeleteUser deletedSubmissions
-      -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
-      defaultLayout
-        $(widgetFile "deletedUser")
-
-    -- (FormSuccess BtnAbort ) -> do
-    --   addMessageI Info MsgAborted
-    --   redirect ProfileDataR
-    _other -> getProfileDataR
-
-
-
-deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
-deleteUser duid = do
-    -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
-    -- We delete all files tied to submissions where the user is the lone submissionUser
-
-    -- Do not deleteCascade submissions where duid is the corrector:
-    updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
-
-    groupSubmissions  <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>.  E.val (0::Int64))
-    singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
-    deleteCascade duid
-    forM_ singleSubmissions $ \(E.Value submissionId) -> do
-      deleteFileIds  <- map E.unValue <$> getSubmissionFiles submissionId
-      deleteCascade submissionId
-      deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
-
-    deletedSubmissionGroups <- deleteSingleSubmissionGroups
-    return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
-  where
-    selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
-    selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
-        E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
-        let numBuddies = E.sub_select $ E.from $ \subUsers -> do
-                E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
-                    E.&&.  subUsers E.^. SubmissionUserUser E.!=. E.val duid
-                return E.countRows
-        E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
-             E.&&. whereBuddies numBuddies
-        return $ submission E.^. SubmissionId
-
-    getSubmissionFiles :: SubmissionId ->  DB [E.Value (Key File)]
-    getSubmissionFiles subId = E.select $ E.from $ \file -> do
-      E.where_ $ E.exists $ E.from $ \submissionFile ->
-          E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
-              E.&&.  submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
-      return $ file E.^. FileId
-
-    deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
-      E.where_ $ E.exists $ E.from $ \subGroupUser ->
-          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
-               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
-      E.where_ $ E.notExists $ E.from $ \subGroupUser ->
-          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
-               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
-
-
 
 getProfileDataR :: Handler Html
 getProfileDataR = do
-  (uid, User{..}) <- requireAuthPair
+  userEnt <- requireAuth
+  dataWidget <- runDB $ makeProfileData userEnt
+  defaultLayout $ do
+    dataWidget
+    $(widgetFile "dsgvDisclaimer")
+
+makeProfileData :: Entity User -> DB Widget
+makeProfileData (Entity uid User{..}) = do
   -- MsgRenderer mr <- getMsgRenderer
-  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
+  admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
-    E.select
+      E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
-      ( E.from $ \(adright `E.InnerJoin` school) -> do
+      E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
-          E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
+      return (school E.^. SchoolShorthand)
-          E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
+  lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
-          return (school E.^. SchoolShorthand)
+      E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
-      )
+      E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
-    <*>
+      return (school E.^. SchoolShorthand)
-    E.select
+  lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
-      ( E.from $ \(lecright `E.InnerJoin` school) -> do
+      E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
-          E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
+      E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-          E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
+      E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
-          return (school E.^. SchoolShorthand)
+      return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
-      )
+  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-    <*>
+      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
-    E.select
+      E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
-      ( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
+      E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-          E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+      return  (studyfeat, studydegree, studyterms)
-          E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+  --Tables
-          E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
+  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
-          return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
+  enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
-      )
+  submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
-    <*>
+  submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
-    E.select
+  correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
-      ( 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  (studyfeat, studydegree, studyterms)
-      )
-  (   (hasRows, ownedCoursesTable)
-    , enrolledCoursesTable
-    , submissionTable
-    , submissionGroupTable
-    , correctionsTable
-    ) <- runDB $ (,,,,)
-           <$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
-           <*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
-           <*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
-           <*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
-           <*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
-
-
   let examTable        = [whamlet|Klausuren werden momentan leider noch nicht unterstützt.|]
   let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
   let tutorialTable    = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-
   lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
-
+  return $(widgetFile "profileData")
-  -- Delete Button
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
-  let btnForm = wrapForm btnWdgt def
-        { formAction = Just $ SomeRoute ProfileDataR
-        , formEncoding = btnEnctype
-        , formSubmit = FormNoSubmit
-        }
-  defaultLayout $ do
-    let delWdgt = $(widgetFile "widgets/data-delete/data-delete")
-    $(widgetFile "profileData")
-    $(widgetFile "dsgvDisclaimer")
 
 
 
@@ -583,3 +491,44 @@ mkCorrectionsTable =
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 
+
+getAuthPredsR, postAuthPredsR :: Handler Html
+getAuthPredsR = postAuthPredsR
+postAuthPredsR = do
+  (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+
+  let
+    blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
+    taForm authTag
+      | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
+      | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
+
+  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
+    $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
+
+  mReferer <- runMaybeT $ do
+    param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
+    MaybeT . return $ fromPathPiece param
+
+  let authActiveForm = wrapForm authActiveWidget' def
+        { formAction = Just $ SomeRoute AuthPredsR
+        , formEncoding = authActiveEnctype
+        , formSubmit = FormDualSubmit
+        }
+      authActiveWidget'
+        = [whamlet|
+            $newline never
+            $maybe referer <- mReferer
+              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
+            ^{authActiveWidget}
+          |]
+
+  formResult authActiveRes $ \authTagActive -> do
+    setSessionJson SessionActiveAuthTags authTagActive
+    modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
+    addMessageI Success MsgAuthPredsActiveChanged
+    redirect $ fromMaybe AuthPredsR mReferer
+
+  siteLayoutMsg MsgAuthPredsActive $ do
+    setTitleI MsgAuthPredsActive
+    $(widgetFile "authpreds")

src/Handler/Sheet.hs

@@ -123,7 +123,6 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
       <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
             & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
       <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
-      <*  submitButton
     return $ case result of
       FormSuccess sheetResult
         | errorMsgs <- validateSheet mr sheetResult
@@ -200,11 +199,12 @@ getSheetListR tid ssh csh = do
             let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
             case mbSub of
               Nothing -> cellTell mempty $ stats Nothing
-              (Just (Entity sid Submission{..})) ->
+              (Just (Entity sid sub@Submission{..})) ->
                 let mkCid = encrypt sid
                     mkRoute = do
                       cid' <- mkCid
                       return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
+                    mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
                     acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
                 in cellTell acell $ stats submissionRatingPoints
 
@@ -787,7 +787,7 @@ postSCorrR = getSCorrR
 getSCorrR tid ssh csh shn = do
   Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
 
-  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs

src/Handler/SystemMessage.hs

@@ -3,7 +3,6 @@ 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
 
@@ -16,13 +15,7 @@ import Utils.Lens
 
 import qualified Database.Esqueleto as E
 
-
+-- htmlField' moved to Handler.Utils.Form/Fields
-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

src/Handler/Term.hs

@@ -3,14 +3,16 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
+import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
--- import qualified Data.Text as T
+import Utils.Lens
-import Yesod.Form.Bootstrap3
--- import Colonnade hiding (bool)
 
 import qualified Database.Esqueleto as E
 
+import qualified Data.Set as Set
+  
+
 -- | Default start day of term for season,
 --   @True@: start of term, @False@: end of term
 defaultDay :: Bool -> Season -> Day
@@ -148,7 +150,7 @@ getTermShowR = do
         setTitleI MsgTermsHeading
         $(widgetFile "terms")
 
-getTermEditR :: Handler Html
+getTermEditR, postTermEditR :: Handler Html
 getTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
@@ -164,18 +166,18 @@ getTermEditR = do
               , tftEnd   = Just $ defaultDay False seas & setYear yr'
               }
   termEditHandler template
-
-postTermEditR :: Handler Html
 postTermEditR = termEditHandler mempty
 
-getTermEditExistR :: TermId -> Handler Html
+getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
-getTermEditExistR tid = do
+getTermEditExistR = postTermEditExistR
+postTermEditExistR tid = do
   term <- runDB $ get tid
   termEditHandler $ termToTemplate term
 
 
 termEditHandler :: TermFormTemplate -> Handler Html
 termEditHandler term = do
+    Just eHandler <- getCurrentRoute
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
       (FormSuccess res) -> do
@@ -194,7 +196,7 @@ termEditHandler term = do
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       wrapForm formWidget def
-        { formAction = Just $ SomeRoute TermEditR
+        { formAction = Just $ SomeRoute eHandler
         , formEncoding = formEnctype
         }
 
@@ -247,14 +249,21 @@ termToTemplate (Just Term{..}) = TermFormTemplate
 newTermForm :: TermFormTemplate -> Form Term
 newTermForm template html = do
     mr <- getMessageRender
+    let
+      tidForm
+        | Just tid <- tftName template
+        = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
+        | otherwise
+        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
+      holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
+      <$> tidForm
       <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
       <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
-      <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
+      <*> (Set.toList . Set.fromList <$> holidayForm)
       <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
       <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
-      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
+      <*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
     return $ case result of
       FormSuccess termResult
         | errorMsgs <- validateTerm termResult

src/Handler/Users.hs

@@ -16,6 +16,8 @@ import qualified Data.Map as Map
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
+import Handler.Profile (makeProfileData)
+
 
 hijackUserForm :: CryptoUUIDUser -> Form ()
 hijackUserForm cID csrf = do
@@ -161,7 +163,7 @@ postAdminUserR uuid = do
     uid <- decrypt uuid
     let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
     let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer)
-    (User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
+    (user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
         <$> get404 uid
         <*> selectList [UserAdminUser ==. adminId] []
         <*> E.select ( E.from $ \school -> do
@@ -176,7 +178,7 @@ postAdminUserR uuid = do
             )
     -- above data is needed for both form generation and result evaluation
     let userRightsForm :: Form [(SchoolId, Bool, Bool)]
-        userRightsForm csrf = do
+        userRightsForm = identifyForm FIDuserRights $ \csrf -> do
           boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) ->
             if Set.member sid adminSchools
               then do
@@ -213,5 +215,84 @@ postAdminUserR uuid = do
     formResult result userRightsAction
     let heading =
           [whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
-    siteLayout heading
+    -- Delete Button needed in data-delete
+    (btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
+    let btnForm = wrapForm btnWgt def
+          { formAction   = Just $ SomeRoute $ AdminUserDeleteR uuid
+          , formEncoding = btnEnctype
+          , formSubmit   = FormNoSubmit
+          }
+    userDataWidget <- runDB $ makeProfileData $ Entity uid user
+    siteLayout heading $ do
+      let deleteWidget   = $(widgetFile "widgets/data-delete/data-delete")
       $(widgetFile "adminUser")
+
+
+postAdminUserDeleteR :: CryptoUUIDUser -> Handler Html
+postAdminUserDeleteR uuid = do
+  uid <- decrypt uuid
+  ((btnResult,_), _) <- runFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
+  case btnResult of
+    (FormSuccess BtnDelete) -> do
+      User{..}  <- runDB $ get404 uid
+      -- clearCreds False -- Logout-User
+      ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
+      -- addMessageIHamlet
+      $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
+      -- addMessageI Success $ MsgDeleteUser deletedSubmissions
+      -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
+      defaultLayout
+        $(widgetFile "deletedUser")
+
+    -- (FormSuccess BtnAbort ) -> do
+    --   addMessageI Info MsgAborted
+    --   redirect ProfileDataR
+    _other -> getAdminUserR uuid
+
+
+
+deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
+deleteUser duid = do
+    -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
+    -- We delete all files tied to submissions where the user is the lone submissionUser
+
+    -- Do not deleteCascade submissions where duid is the corrector:
+    updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
+
+    groupSubmissions  <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>.  E.val (0::Int64))
+    singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
+    deleteCascade duid
+    forM_ singleSubmissions $ \(E.Value submissionId) -> do
+      deleteFileIds  <- map E.unValue <$> getSubmissionFiles submissionId
+      deleteCascade submissionId
+      deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
+
+    deletedSubmissionGroups <- deleteSingleSubmissionGroups
+    return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
+  where
+    selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
+    selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
+        E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
+        let numBuddies = E.sub_select $ E.from $ \subUsers -> do
+                E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+                    E.&&.  subUsers E.^. SubmissionUserUser E.!=. E.val duid
+                return E.countRows
+        E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
+             E.&&. whereBuddies numBuddies
+        return $ submission E.^. SubmissionId
+
+    getSubmissionFiles :: SubmissionId ->  DB [E.Value (Key File)]
+    getSubmissionFiles subId = E.select $ E.from $ \file -> do
+      E.where_ $ E.exists $ E.from $ \submissionFile ->
+          E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
+              E.&&.  submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
+      return $ file E.^. FileId
+
+    deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
+      E.where_ $ E.exists $ E.from $ \subGroupUser ->
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
+      E.where_ $ E.notExists $ E.from $ \subGroupUser ->
+          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
+

src/Handler/Utils.hs

@@ -7,10 +7,11 @@ import Import
 import qualified Data.Text as T
 -- import qualified Data.Set (Set)
 import qualified Data.Set as Set
-import Data.CaseInsensitive (CI, original)
+import Data.CaseInsensitive (original)
 -- import qualified Data.CaseInsensitive as CI
 
-import Language.Haskell.TH (Q, Exp)
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qRunIO)
 -- import Language.Haskell.TH.Datatype
 
 import Text.Hamlet (shamletFile)
@@ -24,9 +25,14 @@ import Handler.Utils.Zip        as Handler.Utils
 import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 -- import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
-import Handler.Utils.Templates  as Handler.Utils
 import Handler.Utils.Mail       as Handler.Utils
 
+import System.Directory (listDirectory)
+import System.FilePath.Posix (takeBaseName)
+
+import qualified Data.List as List
+import qualified Data.List.NonEmpty as NonEmpty
+
 
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
 downloadFiles = do
@@ -44,13 +50,22 @@ simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
 
 -- | toWidget-Version of @nameHtml@, for convenience
-nameWidget :: Text -> Text -> Widget
+nameWidget :: Text    -- ^ userDisplayName
+           -> Text    -- ^ userSurname
+           -> Widget
 nameWidget displayName surname = toWidget $ nameHtml displayName surname
 
 -- | toWidget-Version of @nameEmailHtml@, for convenience
-nameEmailWidget :: CI Text -> Text -> Text -> Widget
+nameEmailWidget :: UserEmail -- ^ userEmail
+                -> Text    -- ^ userDisplayName
+                -> Text    -- ^ userSurname
+                -> Widget
 nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
 
+-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
+nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
+nameEmailWidget' = $(uncurryN 3) nameEmailWidget
+
 -- | Show user's displayName, highlighting the surname if possible.
 --   Otherwise appends the surname in parenthesis
 nameHtml :: Text -> Text -> Html
@@ -72,20 +87,47 @@ nameHtml displayName surname
 
 -- | Like nameHtml just show a users displayname with hightlighted surname,
 --   but also wrap the name with a mailto-link
-nameEmailHtml :: CI Text -> Text -> Text -> Html
+nameEmailHtml :: UserEmail -> Text -> Text -> Html
 nameEmailHtml email displayName surname =
   wrapMailto email $ nameHtml displayName surname
 
 -- | Wrap mailto around given Html using single hamlet-file for consistency
-wrapMailto :: CI Text -> Html -> Html
+wrapMailto :: UserEmail -> Html -> Html
 wrapMailto (original -> email) linkText
   | null email = linkText
   | otherwise  = $(shamletFile "templates/widgets/link-email.hamlet")
 
 -- | Just show an email address in a standard way, for convenience inside hamlet files.
-mailtoHtml :: CI Text -> Html
+mailtoHtml :: UserEmail -> Html
 mailtoHtml email = wrapMailto email $ toHtml email
 
+-- | Generic i18n text for "edited at sometime by someone"
+editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
+editedByW fmt tm usr  = do
+  ft <- handlerToWidget $ formatTime fmt tm
+  [whamlet|_{MsgEditedBy usr ft}|]
+
+-- | Prefix a message with a short course id,
+--   eg. for window title bars, etc.
+--   This function should help to make this consistent everywhere
+prependCourseTitle :: (RenderMessage UniWorX msg) =>
+  TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
+prependCourseTitle tid ssh csh msg = UniWorXMessages
+  [ SomeMessage $ toPathPiece tid
+  , SomeMessage dashText
+  , SomeMessage $ toPathPiece ssh
+  , SomeMessage dashText
+  , SomeMessage csh
+  , SomeMessage colonText
+  , SomeMessage msg
+  ]
+ where
+    dashText :: Text
+    dashText = "-"
+
+    colonText :: Text
+    colonText = ":"
+
 warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
 warnTermDays tid times = do
   Term{..} <- get404 tid
@@ -100,11 +142,30 @@ warnTermDays tid times = do
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
 
 -- | Add language dependent template files
---   For large files which are translated as a whole.
+--
---   Argument musst be a directory under templates,
+-- For large files which are translated as a whole.
---   which contains a file for each language,
+--
---   eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet
+-- Argument musst be a directory under @/templates@,
+-- which contains a file for each language,
+-- eg. @imprint@ for choosing between
+-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
+-- and @/templates/imprint/en.hamlet@
+--
+-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
+-- for directories)
+-- @$ stack clean@ is required so new translations show up
 i18nWidgetFile :: FilePath -> Q Exp
-i18nWidgetFile =
+i18nWidgetFile basename = do
-  -- TODO write code to distinguish languages here
+  -- Construct list of available translations (@de@, @en@, ...) at compile time
-  widgetFile . (</> "de")
+  let i18nDirectory = "templates" </> basename
+  availableFiles <- qRunIO $ listDirectory i18nDirectory
+  let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
+  availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
+
+  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
+  ws <- newName "ws" -- Name for dispatch function
+  letE
+    [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename </> l) []
+                | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
+                ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
+    ] [e|selectLanguage availableTranslations' >>= $(varE ws)|]

src/Handler/Utils/Delete.hs

@@ -1,3 +1,13 @@
+{-|
+Module      : Handler.Utils.Delete
+Description : Generic deletion from database after confirmation
+
+`postDeleteR`, `getDeleteR`, and `deleteR` provide handlers for calling
+`deleteCascade` on a `Set` of Record-`Key`s after asking for confirmation, which
+currently entails asking the user to copy a text, which is dependent on the
+records to be deleted (i.e. a comma-separated list of user names), into a
+`Textarea`.
+-}
 module Handler.Utils.Delete
   ( DeleteRoute(..)
   , deleteR

src/Handler/Utils/Form.hs

@@ -12,7 +12,7 @@ import Handler.Utils.DateTime
 
 import Import hiding (cons)
 import qualified Data.Char as Char
-
+import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 
 -- import Yesod.Core
@@ -45,10 +45,13 @@ import Utils.Lens
 import Data.Aeson (eitherDecodeStrict')
 import Data.Aeson.Text (encodeToLazyText)
 
+import Data.Proxy
 
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
+-- NOTE: ButtonSubmit is defined in Utils.Form !
+
 
 data ButtonDelete = BtnDelete
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
@@ -61,6 +64,23 @@ embedRenderMessage ''UniWorX ''ButtonDelete id
 instance Button UniWorX ButtonDelete where
   btnClasses BtnDelete = [BCIsButton, BCDanger]
 
+data ButtonSave = BtnSave
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonSave
+instance Finite ButtonSave
+
+-- | Save-Button as AForm
+saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m ()
+saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) ""
+
+
+
+nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1
+
+embedRenderMessage ''UniWorX ''ButtonSave id
+instance Button UniWorX ButtonSave where
+  btnClasses BtnSave = [BCIsButton, BCPrimary]
+
 data ButtonRegister = BtnRegister | BtnDeregister
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 instance Universe ButtonRegister
@@ -118,22 +138,20 @@ linkButton lbl cls url = do
   |]
 
 
--- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-buttonForm :: (Button UniWorX a, Finite a) => Form a
-buttonForm csrf = do
-   (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
-   return (res, [whamlet|
-       $newline never
-       #{csrf}
-       $forall bView <- fViews
-         ^{fvInput bView}
-     |])
-
-
 ------------
 -- Fields --
 ------------
 
+-- | add some additional text immediately after the field widget; probably not a good idea to use
+annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
+annotateField ann field@Field{fieldView=fvf} =
+  let fvf' idt nmt atts ei bl =
+        [whamlet|
+          ^{fvf idt nmt atts ei bl}
+          ^{ann}
+        |]
+  in field { fieldView=fvf'}
+
 -- ciField moved to Utils.Form
 
 routeField :: ( Monad m
@@ -141,6 +159,12 @@ routeField :: ( Monad m
               ) => Field m (Route UniWorX)
 routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
 
+-- | Variant that simply removes leading and trailing white space
+htmlField' :: Field (HandlerT UniWorX IO) Html
+htmlField' = htmlField
+  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
+  }
+
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField
 

src/Handler/Utils/Form/MassInput.hs

@@ -3,10 +3,11 @@
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
   , massInput
+  , massInputList
   , BoxDimension(..)
   , IsBoxCoord(..), boxDimension
   , Liveliness(..)
-  , ListLength(..), ListPosition(..)
+  , ListLength(..), ListPosition(..), miDeleteList
   ) where
 
 import Import
@@ -29,7 +30,6 @@ import Data.List (genericLength, genericIndex, iterate)
 
 import Control.Monad.Trans.Maybe
 import Control.Monad.Reader.Class (MonadReader(local))
-import Control.Monad.Fix
 
 
 data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@@ -96,6 +96,13 @@ instance Liveliness ListLength where
           max' = Set.lookupMax ns
   liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
 
+
+miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
+miDeleteList l pos
+    -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
+  | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
+  | otherwise = pure Map.empty
+
 data ButtonMassInput coord
   = MassInputAddDimension Natural coord
   | MassInputDeleteCell coord
@@ -185,7 +192,7 @@ data MassInput handler liveliness cellData cellResult = MassInput
           -> Natural -- Zero-based dimension index @dimIx@
           -> (Text -> Text) -- Nudge deterministic field ids
           -> FieldView UniWorX -- Submit button
-          -> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
+          -> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
   , miCell :: BoxCoord liveliness -- Position
            -> cellData -- @cellData@ from @miAdd@
            -> Maybe cellResult -- Initial result from Argument to @massInput@
@@ -198,13 +205,14 @@ data MassInput handler liveliness cellData cellResult = MassInput
                -> Natural
                -> liveliness
                -> Bool -- ^ Decide whether an addition-operation should be permitted
+  , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
   }
 
 massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadFix handler, MonadLogger handler
+           , MonadLogger handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX
@@ -215,6 +223,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let initialShape = fmap fst <$> initialResult
 
   miName <- maybe newFormIdent return fsName
+  fvId <- maybe newIdent return fsId
+  miAction <- traverse toTextUrl $ miButtonAction fvId
+  let addFormAction = maybe id (addAttr "formaction") miAction
+
   let
     shapeName :: MassInputFieldName (BoxCoord liveliness)
     shapeName = MassInputShape{..}
@@ -230,19 +242,21 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     | otherwise -> throwM MassInputInvalidShape
   sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
 
-  let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (liveliness -> (BoxCoord liveliness, cellData))), Maybe Widget))
+  let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
       addForm = addForm' boxOrigin . zip [0..]
         where
           addForm' _ [] = return Map.empty
           addForm' miCoord ((dimIx, _) : remDims) = do
             let nudgeAddWidgetName :: Text -> Text
                 nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
-            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing
+            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
-            let btnRes
+            let btnRes = do
-                  | FormSuccess  Nothing <- btnRes' = FormMissing
+                  Just x <- btnRes'
-                  | FormSuccess (Just x) <- btnRes' = FormSuccess x
+                  return x
-                  | otherwise                       = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes'
+                wBtnRes res = do
-            addRes' <- over (mapped . _Just . _1) (btnRes *>) . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
+                  guard $ isn't _FormMissing btnRes
+                  res
+            addRes' <- over (mapped . _Just . _1) wBtnRes . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
                   miAdd miCoord dimIx nudgeAddWidgetName btnView
             let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
             case remDims of
@@ -254,9 +268,15 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
                 return $ dimRes' `Map.union` fold dimRess
 
   addResults <- addForm boxDimensions
+  let
+    addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
+    addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
+        FormSuccess (Just mkResult)
+          | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
+        other -> Nothing <$ other
   let addShape
         | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
-        = Just $ maybe id (uncurry Map.insert) (mkResult sentLiveliness <$ guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
+        = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
         | otherwise = Nothing
 
   addedShape <- if
@@ -267,11 +287,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let
     delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
     delForm miCoord = do
-      (delRes, delView) <- lift $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing
+      (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
-      -- dollar comment causes build error somehow  $  logDebugS "delForm" . tshow $ fmap toPathPiece delRes
       shapeUpdate <- miDelete addedLiveliness miCoord
       guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
-      return (shapeUpdate <$ delRes, delView)
+      return (shapeUpdate <$ assertM (is _Just) delRes, delView)
 
   delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
   let
@@ -306,12 +325,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
       | otherwise = prevEnv
 
     justAdded :: Set (BoxCoord liveliness)
-    justAdded = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults
+    justAdded = Map.keysSet shape Set.\\ Map.keysSet sentShape'
-      where
+
-        addedCoord res
-          | FormSuccess (Just mkResult) <- res
-          = Just . fst $ mkResult sentLiveliness
-          | otherwise = Nothing
     restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a
     restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded)
 
@@ -321,9 +336,11 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
       nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
     local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
   let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
-      result
+      result = do
-        | shapeChanged = FormMissing
+        FormSuccess () <|> void (asum $ Map.elems addResults')
-        | otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
+        FormSuccess () <|> void (asum . Map.elems $ fst <$> delResults)
+        guard $ not shapeChanged
+        for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
 
   let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
       miWidget' _ [] = mempty
@@ -343,7 +360,6 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
       miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
 
   MsgRenderer mr <- getMsgRenderer
-  fvId <- maybe newIdent return fsId
 
   let
     fvLabel = toHtml $ mr fsLabel
@@ -351,3 +367,29 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvInput = $(widgetFile "widgets/massinput/massinput")
     fvErrors = Nothing
     in return (result, FieldView{..})
+
+
+-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
+massInputList :: forall handler cellResult.
+                 ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                 , MonadLogger handler
+                 )
+              => Field handler cellResult
+              -> (ListPosition -> FieldSettings UniWorX)
+              -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+              -> FieldSettings UniWorX
+              -> Bool
+              -> Maybe [cellResult]
+              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
+massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
+  MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
+            , miCell = \pos () iRes nudge csrf ->
+                over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
+            , miDelete = miDeleteList
+            , miAllowAdd = \_ _ _ -> True
+            , miButtonAction
+            }
+  miSettings
+  miRequired
+  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

src/Handler/Utils/Submission.hs

@@ -462,10 +462,10 @@ sinkSubmission userId mExists isUpdate = do
             case isUpdate of
               False -> lift . insert_ $ SubmissionEdit userId now submissionId
               True  -> do
-                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId
-                when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
+                when (submissionRatingBy == Just userId) $ do
-                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                  when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
-                -- TODO: Should submissionRatingAssigned change here if userId changes?
+                  lift $ update submissionId [ SubmissionRatingTime =. Just now ]
             tellSt $ mempty{ sinkSubmissionTouched = Any True }
 
         finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()

src/Handler/Utils/Table/Cells.hs

@@ -57,6 +57,10 @@ sqlCell act = mempty & cellContents .~ lift act
 tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell = cell . toWidget . hasTickmark
 
+-- | Maybe display an icon for tainted rows
+isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
+isBadCell = cell . toWidget . isBad
+
 -- | Maybe display a exclamation icon
 isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
 isNewCell = cell . toWidget . isNew

src/Handler/Utils/Table/Columns.hs

@@ -66,8 +66,8 @@ sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>>
 
 defaultSortingByName :: PSValidator m x -> PSValidator m x
 defaultSortingByName =
-  defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
+  -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-  -- defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
+  defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
 
 -- | Alias for sortUserName for consistency
 fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)

src/Handler/Utils/Table/Pagination.hs

@@ -595,7 +595,7 @@ instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]
 instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
 
-
+-- | DB-backed tables with pagination, may short-circuit a handler
 dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
 dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
   let
@@ -639,7 +639,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
     (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
           areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
-      <*  autosubmitButton
     return (filterRes', pagesizeRes')
 
   let
@@ -754,7 +753,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , formAction = Just . SomeRoute $ rawAction :#: wIdent "table-wrapper"
       , formEncoding = pagesizeEnc
       , formAttrs = [("class", "pagesize")]
-      , formSubmit = FormNoSubmit
+      , formSubmit = FormAutoSubmit
       , formAnchor = Just $ wIdent "pagesize-form"
       }
     uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")

src/Handler/Utils/Templates.hs

@@ -1,26 +0,0 @@
-module Handler.Utils.Templates where
-
-import Data.Either (isLeft)
-
-import Import.NoFoundation
-
-modal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO ()
-modal modalTrigger modalContent = do
-  let modalDynamic = isLeft modalContent
-  modalId <- newIdent
-  triggerId <- newIdent
-  $(widgetFile "widgets/modal/modal")
-  case modalContent of
-    Left  route -> do
-      route' <- toTextUrl route
-      [whamlet|
-        $newline never
-        <a .modal__trigger href=#{route'} ##{triggerId}>
-          <span .modal__trigger-label>^{modalTrigger}
-      |]
-    Right _     ->
-      [whamlet|
-        $newline never
-        <div .modal__trigger ##{triggerId}>
-          <span .modal__trigger-label>^{modalTrigger}
-      |]

src/Handler/Utils/TermCandidates.hs

@@ -180,5 +180,8 @@ conflicts = E.select $ E.from $ \studyTerms -> do
         E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
   return studyTerms
 
-
+-- | retrieve all incidence keys having containing a certain @StudyTermKey @
-
+getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
+getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
+  E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
+  return $ candidate E.^. StudyTermCandidateIncidence

src/Import/NoFoundation.hs

@@ -15,6 +15,7 @@ import Yesod.Auth             as Import
 import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Utils                  as Import
+import Utils.Modal            as Import
 import Yesod.Core.Json        as Import (provideJson)
 import Yesod.Core.Types.Instances as Import ()
 
@@ -41,7 +42,8 @@ import GHC.Exts               as Import (IsList)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
-import Data.Text.Encoding.Error    as Import(UnicodeException(..))
+import Data.List.NonEmpty.Instances as Import ()
+import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.Instances  as Import ()

src/Jobs/Handler/HelpRequest.hs

@@ -16,10 +16,11 @@ import Data.Bitraversable
 
 dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> UTCTime
+                       -> Maybe Text -- ^ Help Subject
                        -> Text -- ^ Help Request
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
-dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
+dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
   supportAddress <- getsYesod $ appMailSupport . appSettings
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let userAddress = either
@@ -28,8 +29,9 @@ dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
         userInfo
   mailT def $ do
     _mailTo .= [supportAddress]
-    whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
+    whenIsJust userAddress (_mailFrom .=)
-    setSubjectI MsgMailSubjectSupport
+    replaceMailHeader "Auto-Submitted" $ Just "no"
+    setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
     setDate jRequestTime
     rtime <- formatTimeMail SelFormatDateTime jRequestTime
     addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -22,6 +22,7 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
                      ]
     return (course, sheet, nbrSubs)
   when (nbrSubs > 0) . userMailT jRecipient $ do 
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
 
     MsgRenderer mr <- getMailMsgRenderer

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

@@ -19,6 +19,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
                      ]
     return (course, sheet, nbrSubs)
   when (nbrSubs > 0) . userMailT jRecipient $ do 
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -17,6 +17,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
     sheet <- getJust nSheet
     course <- belongsToJust sheetCourse sheet
     return (course, sheet)
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
 
   MsgRenderer mr <- getMailMsgRenderer

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -20,6 +20,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
     sheet <- getJust nSheet
     course <- belongsToJust sheetCourse sheet
     return (course, sheet)
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
 
   MsgRenderer mr <- getMailMsgRenderer
@@ -45,6 +46,7 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
         -- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser
         return (E.countRows :: E.SqlExpr (E.Value Int64))
     return (course, sheet, nrSubs, nrSubmitters)
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
 
   MsgRenderer mr <- getMailMsgRenderer

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -22,6 +22,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
     course <- belongsToJust sheetCourse sheet
     corrector <- traverse getJust submissionRatingBy
     return (course, sheet, submission, corrector)
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
 
   csid <- encrypt nSubmission

src/Jobs/Handler/SendNotification/UserRightsUpdate.hs

@@ -19,6 +19,7 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
       adminSchools    <- getSchoolsOf nUser UserAdminSchool    UserAdminUser
       lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
       return (user,adminSchools,lecturerSchools)
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
     addAlternatives $ do

src/Jobs/Handler/SendTestEmail.hs

@@ -13,6 +13,7 @@ import Utils.Lens
 dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
 dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
   _mailTo .= [Address Nothing jEmail]
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI MsgMailTestSubject
   now <- liftIO getCurrentTime
   nDT <- formatTimeMail SelFormatDateTime now

src/Jobs/Types.hs

@@ -17,7 +17,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
          | JobQueueNotification { jNotification :: Notification }
          | JobHelpRequest { jSender :: Either (Maybe Address) UserId
                           , jRequestTime :: UTCTime
-                          , jHelpRequest :: Text, jReferer :: Maybe Text }
+                          , jHelpSubject :: Maybe Text
+                          , jHelpRequest :: Text
+                          , jReferer :: Maybe Text
+                          }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)

src/Mail.hs

@@ -27,7 +27,7 @@ module Mail
   , setSubjectI, setMailObjectId, setMailObjectId'
   , setDate, setDateCurrent
   , setMailSmtpData
-  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
 
@@ -99,9 +99,18 @@ import Data.Universe.Instances.Reverse.Hashable ()
 
 import GHC.Exts (IsList)
 
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+  
+
 makeLenses_ ''Mail
 makeLenses_ ''Part
 
+_mailHeader :: CI ByteString -> Traversal' Mail Text
+_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+
 
 newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
   deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
@@ -443,7 +452,10 @@ setDate time = do
 
 setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
 setMailSmtpData = do
-  Address _ from <- use _mailFrom
+  Just (Address _ from) <- runMaybeT $ asum
+    [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
+    , use _mailFrom
+    ]
   recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
 
   tell $ mempty { smtpRecipients = recps }

src/Model/Types.hs

@@ -772,6 +772,20 @@ instance FromJSON AuthTagActive where
 derivePersistFieldJSON ''AuthTagActive
 
 
+
+data LecturerType = CourseLecturer | CourseAssistant
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe LecturerType
+instance Finite LecturerType
+
+nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''LecturerType
+derivePersistFieldJSON ''LecturerType
+
+
 -- Type synonyms
 
 type Email           = Text

src/Utils.hs

@@ -85,11 +85,6 @@ getMsgRenderer = do
   return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
 
 
-instance Monad FormResult where
-  FormMissing        >>= _ = FormMissing
-  (FormFailure errs) >>= _ = FormFailure errs
-  (FormSuccess a)    >>= f = f a
-
 guardAuthResult :: MonadHandler m => AuthResult -> m ()
 guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t
@@ -145,8 +140,13 @@ hasTickmark :: Bool -> Markup
 hasTickmark True  = [shamlet|<i .fas .fa-check>|]
 hasTickmark False = mempty
 
+isBad :: Bool -> Markup
+-- ^ Display an icon that denotes that something™ is bad
+isBad True  = [shamlet|<i .fas .fa-bolt>|] -- or times?!
+isBad False = mempty
+
 isNew :: Bool -> Markup
-isNew True  = [shamlet|<i .fas .fa-exclamation>|]
+isNew True  = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
 isNew False = mempty
 
 
@@ -325,6 +325,14 @@ mergeAttrs = mergeAttrs' `on` sort
     mergeAttrs' xs1 [] = xs1
 
 
+-- | Copied form Util from package ghc
+partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
+-- ^ Uses a function to determine which of two output lists an input element should join
+partitionWith _ [] = ([],[])
+partitionWith f (x:xs) = case f x of
+                         Left  b -> (b:bs, cs)
+                         Right c -> (bs, c:cs)
+    where (bs,cs) = partitionWith f xs
 
 ----------
 -- Sets --
@@ -447,6 +455,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
 exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
 exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
 
+formResultToMaybe :: Alternative m => FormResult a -> m a
+formResultToMaybe (FormSuccess x) = pure x
+formResultToMaybe  _              = empty
 
 ------------
 -- Either --
@@ -532,10 +543,11 @@ ifM c m m' =
     do  b <- c
         if b then m else m'
 
--- | @ifNotM mc = ifM (not <$> mc)@
+-- | @ifNotM mc = ifM (not <$> mc)@  from Agda.Utils.Monad
 ifNotM :: Monad m => m Bool -> m a -> m a -> m a
 ifNotM c = flip $ ifM c
 
+-- | Monadic boolean function, copied from Andreas Abel's utility function
 and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
 and2M ma mb = ifM ma mb (return False)
 or2M ma = ifM ma (return True)
@@ -575,7 +587,8 @@ mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
 mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
 mconcatForM = flip mconcatMapM
 
-
+findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
+findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
 
 -----------------
 -- Alternative --
@@ -605,9 +618,9 @@ modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (dele
 tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
 tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
 
-getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
 -- ^ `lookupSessionJson` followed by `deleteSession`
-getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
+takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 
 --------------------
 -- GET Parameters --

src/Utils/Form.hs

@@ -3,6 +3,7 @@
 module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
+import Yesod.Core.Instances ()
 import Settings
 
 import Utils.Parameters
@@ -98,6 +99,11 @@ addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
       | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
       | otherwise = p : newAttrs t
 
+addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
+  where
+    placeholderAttr = "placeholder"
+
 addClass :: Text -> FieldSettings site -> FieldSettings site
 addClass = addAttr "class"
 
@@ -107,6 +113,9 @@ addClasses = addAttrs "class"
 addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
 addName nm fs = fs { fsName = Just $ toPathPiece nm }
 
+addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
+addId fid fs = fs { fsId = Just $ toPathPiece fid }
+
 addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
 addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
 
@@ -176,7 +185,10 @@ data FormIdentifier
   | FIDDBTable
   | FIDDelete
   | FIDCourseRegister
+  | FIDuserRights
+  | FIDcUserNote
   | FIDAdminDemo
+  | FIDUserDelete
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -198,7 +210,7 @@ identifyForm' resLens identVal form fragment = do
           |]
 
     -- Check if we got its value back.
-    hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier 
+    hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
 
     -- Run the form proper (with our hidden <input>).  If the
     -- data is missing, then do not provide any params to the
@@ -210,7 +222,7 @@ identifyForm' resLens identVal form fragment = do
 
 identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
 identifyForm = identifyForm' id
-  
+
 
 {- Hinweise zur Erinnerung:
   - identForm primär, wenn es mehr als ein Formular pro Handler gibt
@@ -240,6 +252,7 @@ data ButtonMessage = MsgAmbiguousButtons
                    | MsgMultipleButtonValues
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
+-- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form
 data ButtonSubmit = BtnSubmit
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
@@ -303,6 +316,7 @@ combinedButtonFieldF :: forall m a.
                       ) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
 combinedButtonFieldF = combinedButtonField (universeF :: [a])
 
+-- | Ensures that only a single button press is accepted at once
 disambiguateButtons :: forall m a.
                      ( MonadHandler m
                      , RenderMessage (HandlerSite m) ButtonMessage
@@ -341,6 +355,17 @@ submitButtonView = do
   fieldView bField btnId "" mempty (Right BtnSubmit) False
 
 
+buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
+buttonForm csrf = do
+  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
+  return (res, [whamlet|
+      $newline never
+      #{csrf}
+      $forall bView <- fViews
+        ^{fvInput bView}
+    |])
+
+
 -------------------
 -- Custom Fields --
 -------------------

src/Utils/Modal.hs

@@ -0,0 +1,42 @@
+module Utils.Modal
+  ( Modal(..)
+  , customModal
+  , modal
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Control.Lens
+import Control.Lens.Extras (is)
+import Utils.Route
+
+import Settings (widgetFile)
+
+
+data Modal site = Modal
+  { modalTriggerId
+  , modalId :: Maybe Text
+  , modalTrigger :: Maybe Text {- Dynamic URL -} -> Text {- TriggerId -} -> WidgetT site IO ()
+  , modalContent :: Either (SomeRoute site) (WidgetT site IO ())
+  }
+
+customModal :: Modal site -> WidgetT site IO ()
+customModal Modal{..} = do
+  let isDynamic = is _Left modalContent
+  modalId' <- maybe newIdent return modalId
+  triggerId' <- maybe newIdent return modalTriggerId
+
+  $(widgetFile "widgets/modal/modal")
+
+  route <- for (modalContent ^? _Left) toTextUrl
+  modalTrigger route triggerId'
+
+-- | Create a link to a modal
+modal :: WidgetT site IO () -- ^ Widget that represents the link
+      -> Either (SomeRoute site) (WidgetT site IO ()) -- ^ Modal contant: either dynamic link or static widget
+      -> WidgetT site IO () -- ^ result widget
+modal modalTrigger' modalContent = customModal Modal{..}
+  where
+    modalTriggerId = Nothing
+    modalId = Nothing
+    modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")

src/Utils/TH.hs

@@ -24,7 +24,7 @@ projNI n i = do
   x <- newName "x"
   let rhs = varE x
   let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
-  lamE [pat] rhs
+  lam1E pat rhs
 
 
 -- | Generic projections N-tuples that are actually left-associative pairs
@@ -83,6 +83,14 @@ uncurryN n = do
   return $ LamE pat rhs
 
 
+afterN :: Int -> ExpQ -- apply a function after another of arity N, i.e. $(afterN 1) = (.)
+afterN n = do
+  f <- newName "f"
+  g <- newName "g"
+  --let rhs = [|$(curryN n) (g . ($(uncurryN n) f))|]
+  lamE [varP g, varP f] [|$(curryN n) $(varE g) . $(uncurryN n) $(varE f)|]
+
+
 -- Special Show-Instances for Themes
 deriveShowWith :: (String -> String) -> Name -> Q [Dec]
 deriveShowWith = deriveSimpleWith ''Show 'show

src/Yesod/Core/Instances.hs

@@ -4,6 +4,7 @@ module Yesod.Core.Instances
   (
   ) where
 
+import Prelude (errorWithoutStackTrace)
 import ClassyPrelude.Yesod
 
 import Utils (assertM')
@@ -14,6 +15,12 @@ import Data.ByteString.Builder (toLazyByteString)
 import System.FilePath ((</>))
 
 import Data.Aeson
+
+import Control.Monad.Fix
+import Control.Monad.Fail (MonadFail)
+import qualified Control.Monad.Fail as MonadFail
+import Control.Monad.Except (MonadError(..))
+import Data.Functor.Extend
   
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
@@ -39,3 +46,34 @@ instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
 
 instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
   toJSON = String . toPathPiece
+
+
+instance Monad FormResult where
+  (FormSuccess a)    >>= f = f a
+  FormMissing        >>= _ = FormMissing
+  (FormFailure errs) >>= _ = FormFailure errs
+
+  fail = MonadFail.fail
+
+instance MonadFail FormResult where
+  fail _ = FormMissing
+
+instance MonadError [Text] FormResult where
+  throwError = FormFailure
+
+  catchError a@(FormSuccess _)    _ = a
+  catchError    FormMissing       _ = FormMissing
+  catchError   (FormFailure errs) h = h errs
+
+instance MonadPlus FormResult
+
+instance MonadFix FormResult where
+  mfix f = let a = f (unSuccess a) in a
+    where unSuccess (FormSuccess x) = x
+          unSuccess  FormMissing    = errorWithoutStackTrace "mfix FormResult: FormMissing"
+          unSuccess (FormFailure _) = errorWithoutStackTrace "mfix FormResult: FormFailure"
+
+instance Extend FormResult where
+  duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
+  duplicated  FormMissing       = FormMissing
+  duplicated (FormFailure errs) = FormFailure errs

src/index.md

@@ -86,7 +86,7 @@ Handler.Utils.Table.Pagination.Types
 Handler.Utils.Table.Cells
   : extends dbTable with UniWorX specific functions, such as special courseCell
 
-Handler.Utils.Templates
+Utils.Modal
   : Modals
 
 Handler.Utils.Zip

static/css/utils/inputs.scss

@@ -25,27 +25,26 @@
   color: var(--color-fontsec);
 }
 
-.form-group__label {
+.form-group-label {
   font-weight: 600;
   padding-top: 6px;
 }
 
-.form-group__hint {
+.form-group-label__hint {
   margin-top: 7px;
   color: var(--color-fontsec);
   font-size: 0.9rem;
 }
 
 .form-group--required {
-
+  .form-group-label__caption::after {
-  .form-group__label::after {
     content: ' *';
     color: var(--color-error);
   }
 }
 
 .form-group--optional {
-  .form-group__label::after {
+  .form-group-label__caption::after {
     content: '';
   }
 }
@@ -66,6 +65,14 @@
   input, textarea {
     border-color: var(--color-error) !important;
   }
+
+  .form-error {
+    display: block;
+  }
+}
+
+.form-error {
+  display: none;
 }
 
 @media (max-width: 768px) {

static/js/utils/form.js

@@ -8,6 +8,9 @@
   var AUTOSUBMIT_BUTTON_SELECTOR = '[type="submit"][data-autosubmit]';
   var AJAX_SUBMIT_FLAG = 'ajaxSubmit';
 
+  var FORM_GROUP_CLASS = 'form-group';
+  var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error';
+
   function formValidator(inputs) {
     var done = true;
     inputs.forEach(function(inp) {
@@ -20,8 +23,15 @@
   }
 
   window.utils.form = function(form, options) {
+    options = options || {};
 
-    if (form.classList.contains(JS_INITIALIZED)) {
+    // dont initialize form if it is in a modal and is not forced
+    if (form.closest('.modal') && !options.force) {
+      return false;
+    }
+
+    // dont initialize form if already initialized and should not be force-initialized
+    if (form.classList.contains(JS_INITIALIZED) && !options.force) {
       return false;
     }
 
@@ -45,6 +55,12 @@
     // inputs
     utilInstances.push(window.utils.setup('inputs', form, options));
 
+    // form group errors
+    var formGroups = Array.from(form.querySelectorAll('.' + FORM_GROUP_CLASS));
+    formGroups.forEach(function(formGroup) {
+      utilInstances.push(window.utils.setup('errorRemover', formGroup, options));
+    });
+
     form.classList.add(JS_INITIALIZED);
 
     function destroyUtils() {
@@ -158,4 +174,29 @@
       destroy: function() {},
     };
   };
+
+  // listens for focus events and removes any errors on an input
+  window.utils.errorRemover = function(formGroup, options) {
+
+    var inputElement = formGroup.querySelector('input:not([type="hidden"]), textarea, select');
+    if (!inputElement) {
+      return false;
+    }
+
+    inputElement.addEventListener('focus', focusListener);
+
+    function focusListener() {
+      var hasError = formGroup.classList.contains(FORM_GROUP_WITH_ERRORS_CLASS);
+      if (hasError) {
+        formGroup.classList.remove(FORM_GROUP_WITH_ERRORS_CLASS);
+      }
+    }
+
+    return {
+      scope: formGroup,
+      destroy: function() {
+        inputElement.removeEventListener('focus', focusListener);
+      },
+    };
+  };
 })();

static/js/utils/inputs.js

@@ -3,37 +3,37 @@
 
   window.utils = window.utils || {};
 
-  var JS_INITIALIZED_CLASS = 'js-initialized';
+  var JS_INITIALIZED_CLASS = 'js-inputs-initialized';
-
-  function isNotInitialized(element) {
-    return !element.classList.contains(JS_INITIALIZED_CLASS);
-  }
 
   window.utils.inputs = function(wrapper, options) {
-
+    options = options || {};
     var utilInstances = [];
 
+    if (wrapper.classList.contains(JS_INITIALIZED_CLASS) && !options.force) {
+      return false;
+    }
+
     // checkboxes
     var checkboxes = Array.from(wrapper.querySelectorAll('input[type="checkbox"]'));
-    checkboxes.filter(isNotInitialized).forEach(function(checkbox) {
+    checkboxes.forEach(function(checkbox) {
       utilInstances.push(window.utils.setup('checkbox', checkbox));
     });
 
     // radios
     var radios = Array.from(wrapper.querySelectorAll('input[type="radio"]'));
-    radios.filter(isNotInitialized).forEach(function(radio) {
+    radios.forEach(function(radio) {
       utilInstances.push(window.utils.setup('radio', radio));
     });
 
     // file-uploads
     var fileUploads = Array.from(wrapper.querySelectorAll('input[type="file"]'));
-    fileUploads.filter(isNotInitialized).forEach(function(input) {
+    fileUploads.forEach(function(input) {
       utilInstances.push(window.utils.setup('fileUpload', input, options));
     });
 
     // file-checkboxes
     var fileCheckboxes = Array.from(wrapper.querySelectorAll('.file-checkbox'));
-    fileCheckboxes.filter(isNotInitialized).forEach(function(input) {
+    fileCheckboxes.forEach(function(input) {
       utilInstances.push(window.utils.setup('fileCheckbox', input, options));
     });
 
@@ -45,6 +45,8 @@
       });
     }
 
+    wrapper.classList.add(JS_INITIALIZED_CLASS);
+
     return {
       scope: wrapper,
       destroy: destroyUtils,
@@ -74,7 +76,6 @@
     if (!i18n) {
       throw new Error('window.utils.fileUpload(input, options) needs to be passed i18n object via options');
     }
-    input.classList.add(JS_INITIALIZED_CLASS);
 
     function renderFileList(files) {
       fileList.innerHTML = '';
@@ -166,8 +167,6 @@
         cont = cont.parentNode;
       }
       addListener(cont);
-      input.classList.add(JS_INITIALIZED_CLASS);
-      cont.classList.add(JS_INITIALIZED_CLASS);
     }
 
     setup();
@@ -190,7 +189,6 @@
       labelEl.setAttribute('for', input.id);
       wrapperEl.appendChild(input);
       wrapperEl.appendChild(labelEl);
-      input.classList.add(JS_INITIALIZED_CLASS);
 
       if (siblingEl) {
         parentEl.insertBefore(wrapperEl, siblingEl);
@@ -219,7 +217,6 @@
         wrapperEl.appendChild(siblingEl);
       }
 
-      input.classList.add(JS_INITIALIZED_CLASS);
       parentEl.appendChild(wrapperEl);
     }
 
@@ -233,8 +230,6 @@
   window.utils.implicitSubmit = function(input, options) {
     var submit = options.submit;
 
-    console.log('implicitSubmit', input, submit);
-
     if (!submit) {
       throw new Error('window.utils.implicitSubmit(input, options) needs to be passed a submit element via options');
     }
@@ -247,7 +242,7 @@
     };
 
     input.addEventListener('keypress', doSubmit);
-    
+
     return {
       scope: input,
       destroy: function() {

static/js/utils/modal.js

@@ -75,7 +75,7 @@
     function setupForm() {
       var form = modalElement.querySelector('form');
       if (form) {
-        utilInstances.push(window.utils.setup('form', form, { headers: MODAL_HEADERS }));
+        utilInstances.push(window.utils.setup('form', form, { headers: MODAL_HEADERS, force: true }));
       }
     }
 

static/js/utils/setup.js

@@ -37,6 +37,9 @@
 
       if (isAlreadySetup) {
         console.warn('Trying to setup a JS utility that\'s already been set up', { utility: utilName, scope, options });
+        if (!options.force) {
+          return false;
+        }
       }
     }
 

templates/adminTest.hamlet

@@ -1,17 +1,14 @@
-<div .container>
+<section>
-  <h1>Uni2work - Admin Demopage
-
   <p data-tooltip="Solch ein Tooltip kann mit dem <em>data-tooltip</em> Attribut erzeugt werden. Funktioniert aber nur in Block-Elementen die einen sinnvollen Wrapper haben.">
     Diese interne Seite dient lediglich zum Testen diverser Funktionalitäten
     und zur Demonstration der verschiedenen Hilfsfunktionen/Module.
 
     Der Handler sollte jeweils aktuelle Beispiele für alle möglichen Funktionalitäten enthalten, so dass man immer weiß, wo man nachschlagen kann.
 
-
+<section>
-<div .container.js-show-hide>
   <h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
 
-  <ul .js-show-hide__target>
+  <ul>
     <li .list-group-item>
       <a href=@{UsersR}>Benutzer Verwaltung
 
@@ -22,7 +19,7 @@
     <li .list-group-item>
       <a href=@{CourseNewR}>Kurse anlegen
 
-<div .container>
+<section>
   <h2>Funktionen zum Testen
 
   <ul>

templates/adminUser.hamlet

@@ -1,4 +1,11 @@
-<p>
+<section>
-  $# Does not use link-email.hamlet, but should
   ^{mailtoHtml userEmail}
-^{form}
+  ^{form}
+<section>
+  ^{userDataWidget}
+  <h3>
+    ^{modal "Benutzer löschen" (Right deleteWidget)}
+  Achtung, dieser Link löscht momentan noch den kompletten Benutzer
+  unwiderruflich aus der Live-Datenbank mit
+  <code>DELETE CASCADE uid
+  \ Klausurdaten müssen jedoch langfristig gespeichert werden!

templates/course-participants.hamlet

@@ -0,0 +1,7 @@
+$# Shows all participants of a course, but no homework statistics
+$# Should at some point allow email messaging
+$#
+$# participantTable : widget table
+
+^{participantTable}
+_{MsgCourseMembersCountOf (fromIntegral numParticipants) (courseCapacity course)}.

templates/course-user.hamlet

@@ -0,0 +1,49 @@
+<section>
+  <div .profile>
+    <dl .deflist.profile-dl>
+        <dt .deflist__dt> _{MsgEMail}
+        <dd .deflist__dd> #{mailtoHtml userEmail}
+        <dt .deflist__dt> _{MsgMatrikelNr}
+        <dd .deflist__dd>
+          $maybe matnr <- userMatrikelnummer
+            #{matnr}
+          $nothing
+            _{MsgNoMatrikelKnown}
+        <dt .deflist__dt>_{MsgRegisteredHeader}
+        <dd .deflist__dd>
+          <div .course__registration>
+            <a id="register-form">
+            <form method=post action=@{currentRoute}#register-form enctype=#{registerEnctype}>
+              ^{registerView}
+            $maybe date <- mRegAt
+              _{MsgRegisteredSince date}
+
+
+        <dt .deflist__dt> _{MsgStudyTerms}
+        <dd .deflist__dd>
+          $if null studies
+            _{MsgNoStudyTermsKnown}
+          $else
+            <div .scrolltable>
+              <table .table.table--striped.table--hover.table--condensed>
+                <tr .table__row>
+                  <th .table__th>_{MsgStudyTerm}
+                  <th .table__th>_{MsgStudyFeatureDegree}
+                  <th .table__th>_{MsgStudyFeatureType}
+                  <th .table__th>_{MsgStudyFeatureAge}
+                  <th .table__th>_{MsgStudyFeatureValid}
+                  <th .table__th>_{MsgStudyFeatureUpdate}
+                $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
+                  $with _ <- notUsedT studyFeaturesUser
+                  <tr.table__row>
+                    <td .table__td>_{field}#{notUsedT studyFeaturesField}
+                    <td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
+                    <td .table__td>_{studyFeaturesType}
+                    <td .table__td>#{display studyFeaturesSemester}
+                    <td .table__td>#{hasTickmark studyFeaturesValid}
+                    <td .table__td>^{formatTimeW SelFormatDate studyFeaturesUpdated}
+
+<section>
+  <a id="note-form">
+  <form method=post action=@{currentRoute}#note-form enctype=#{noteEnctype}>
+    ^{noteView}

templates/course.hamlet

@@ -19,8 +19,18 @@
       <dd .deflist__dd>
         <div>
           <ul .list--inline .list--comma-separated>
-            $forall (E.Value displayname, E.Value surname, E.Value email) <- lecturers
+            $forall lect <- lecturers
-              <li>^{nameEmailWidget email displayname surname}
+              <li>^{nameEmailWidget' lect}
+    $with numassi <- length assistants
+      $if numassi > 1
+        <dt .deflist__dt>_{MsgAssistantsFor}
+      $else
+        <dt .deflist__dt>_{MsgAssistantFor}
+      <dd .deflist__dd>
+        <div>
+          <ul .list--inline .list--comma-separated>
+            $forall assi <- assistants
+              <li>^{nameEmailWidget' assi}
 
     $maybe link <- courseLinkExternal course
       <dt .deflist__dt>Website

templates/default-layout.lucius

@@ -474,7 +474,7 @@ ul.list--inline {
 /* DEFINITION LIST */
 .deflist {
   display: grid;
-  grid-template-columns: 100% ;
+  grid-template-columns: 100%;
 }
 .deflist__dt,
 .deflist__dd {
@@ -488,6 +488,10 @@ ul.list--inline {
 .deflist__dd {
   font-size: 18px;
   margin-bottom: 10px;
+
+  > p {
+    margin-top: 0;
+  }
 }
 
 @media (min-width: 768px) {
@@ -507,7 +511,6 @@ ul.list--inline {
 
   .deflist__dt,
   .deflist__dd {
-    border-bottom: 1px solid #d3d3d3;
     padding: 12px 0;
     margin: 0;
     font-size: 16px;
@@ -527,17 +530,15 @@ ul.list--inline {
 }
 
 section {
-    padding-bottom: 20px;
+    padding-bottom: 30px;
-    margin-bottom: 20px;
     border-bottom: 1px solid #d3d3d3;
 
     + section {
-      margin-top: 20px;
+        margin-top: 20px;
-      padding-top: 20px;
     }
 
-    section {
+    &:last-child {
-      border-bottom: none;
+        border-bottom: none;
     }
 }
 

templates/deletedUser.hamlet

@@ -1,6 +1,10 @@
 <div .container>
   <h1>
     _{MsgUserAccountDeleted userDisplayName}
+  <div .container>
+    #{nameEmailHtml userEmail userDisplayName userSurname}
+  <div .container>
+    #{mailtoHtml userEmail}
   <div .container>
     #{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht.
   $if groupSubmissions > 0
@@ -12,5 +16,3 @@
   $if deletedSubmissionGroups > 0
     <div .container>
       #{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden.
-  <div .container>
-    Good Bye!

templates/featureList.hamlet

@@ -6,7 +6,6 @@
       <h4>
         aus UniWorX bekannt:
       <ul>
-        <li> Studiengänge von Benutzern werden noch ignoriert
         <li> Übungsgruppen
         <li> Klausuren
         <li> Zentralanmeldungen
@@ -14,7 +13,7 @@
       <h4>
         neue geplante Features:
       <ul>
-        <li> Stundenplan/Kalender mit Veranstaltungen und Klausuren
+        <li> Stundenplan/Kalender mit allen Veranstaltungen und Klausuren
         <li> Vollständige Vorlesungshomepages
         <li> Vollständige Internationalisierung deutsch/englisch/...
 

templates/help.hamlet

@@ -1,3 +1,3 @@
 <p>
   _{MsgHelpIntroduction}
-^{form}
+^{formWidget}

templates/home.hamlet

@@ -1,5 +0,0 @@
-<div .container>
-  <h2>
-    Kurse mit offener Registrierung
-  <div .container>
-    ^{courseTable}

templates/home/openCourses.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeOpenCourses}
+  ^{courseTable}

templates/home/upcomingSheets.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeUpcomingSheets}
+  ^{sheetTable}

templates/homeUser.hamlet

@@ -1,17 +0,0 @@
-<div .container>
-  <h2>
-    Anstehende Übungsblätter
-  <div .container>
-    ^{sheetTable}
-
-<!--
-<div .container>
-  <h1>
-    Anstehende Klausuren
-  TODO
-
-<div .container>
-  <h1>
-    Anstehende Kursanmeldungen
-  TODO
--->

templates/info-lecturer/de.hamlet

@@ -1,47 +1,18 @@
+$newline text
+<section>
+  UniWorX erfahrene Veranstalter finden
+  hier die wichtigsten Neuerungen.
 
-UniWorX erfahrene Veranstalter finden
-hier die wichtigsten Neuerungen.
 <section>
   <h2>Bekannte Probleme in Bearbeitung
 
   <dl .deflist>
+    <dt .deflist__dt>Derzeit keine bekannt.
+
+
     $#
     $# MOVE ITEM TO SECTION "VERANSTALTUNGEN", once it is implemented:
     $#
-    <dt .deflist__dt> Kurs Assistenten
-    <dd .deflist__dd>
-      Momentan ist leider nur ein Dozent/Veranstalter pro Kurs erlaubt.
-
-      <p>
-        <h4>Folgendes ist in Vorbereitung:
-        Kurs-Veranstalter dürfen <em>beliebige</em> Personen
-        ebenfalls zu Veranstaltern des Kurses machen.
-
-        Innerhalb des Kurses haben alle Kurs-Veranstalter die
-        gleichen Befugnisse und können insbesondere auch die
-        Liste der Veranstalter dieses Kurses bearbeiten.
-
-      <p>
-        <h4>Unterschied zu UniWorX:
-
-        In Uni2work gibt es die Rollen "Dozent"
-        und "Veranstalter":
-        Dozenten dürfen im Wesentlichen neue Kurse erstellen.
-        Veranstalter haben vollen Zugriff auf einen speziellen Kurs.
-
-        Die Dozenten Berechtigung wird nach Instituten unterschieden.
-
-      <p>
-        In UniWorX gab es die Rolle "Assistent",
-        d.h. alle "Veranstalter" mussten auch "Dozent" sein;
-        eine Unterscheidung nach Instituten gab es nicht.
-
-    <dt .deflist__dt> Kurs Teilnehmer
-    <dd .deflist__dd>
-      Anzeige und Benachrichtigung angemeldeter
-      Kurs-Teilnehmer ist leider noch nicht fertig implementiert.
-      Voraussichtlich vor Start des Sommersemesters 2019 verfügbar.
-
 
 <section>
   <h2>Veranstaltungen
@@ -74,6 +45,54 @@ hier die wichtigsten Neuerungen.
     <dt .deflist__dt> Kurs Passwort
     <dd .deflist__dd> Die Anmeldung zum Kurs kann durch ein Passwort geschützt werden.
 
+    <dt .deflist__dt> Kurs Assistenten
+    <dd .deflist__dd>
+      <p>
+        Kurs-Veranstalter dürfen <em>beliebige</em> Personen
+        ebenfalls zu Veranstaltern des Kurses machen.
+
+        Innerhalb des Kurses haben alle Kurs-Veranstalter die
+        gleichen Befugnisse und können insbesondere auch die
+        Liste der Veranstalter dieses Kurses bearbeiten.
+
+      <p>
+        <h4>Unterschied zu UniWorX:
+
+        In Uni2work gibt es die Rollen "Dozent"
+        und "Assistent":
+        Dozenten dürfen im Wesentlichen neue Kurse erstellen.
+        Die Dozenten Berechtigung wird nach Instituten unterschieden.
+
+        Assistenten haben nur Zugriff auf einen speziellen Kurs,
+        aber innerhalb dieses Kurses die gleichen Rechte wie Dozenten.
+
+      <p>
+        In UniWorX gab es die Rolle "Assistent",
+        d.h. alle "Veranstalter" mussten auch "Dozent" sein;
+        eine Unterscheidung nach Instituten gab es nicht.
+
+    <dt .deflist__dt> Kurs Teilnehmer
+    <dd .deflist__dd>
+      <p>
+        Für die Teilnehmer eines Kurses werden nun Studiengangsinformationen angzeigt.
+        Studierende mit mehreren simultanen Studiengängen müssen bei der
+        Kursanmeldung ein Hauptfach auswählen, was die Notenmeldung beschleunigen kann.
+
+      <p>
+        Falls Anstatt eines Studienganges oder eines Studienabschlusses nur eine
+        Nummer angzeigt wird, so hat Uni2work die Zuordnung dieser Schlüsselnummern
+        leider noch nicht erlernt. Dies muss leider sukzessive erfolgen, da wir
+        von der Studentenkanzelei keine aktuelle und vollständige Schlüsselzuordnung
+        bekommen können.
+
+    <dt .deflist__dt> Aus Studentensicht
+    <dd .deflist__dd>
+      <p>
+        UniWorX hatte spezielle Links "Aus Studentensicht", welche in Uni2work überflüssig geworden sind.
+        Stattdessen kann man sich in Uni2work #
+          <a href=@{AuthPredsR}>Berechtigungen hier temporär selbst entziehen
+        . Um die eigene Veranstaltung aus Sicht eines Teilnehmers zu sehen, deaktiviert man #
+        die Berechtigungsprüfungen "_{MsgAuthTagLecturer}" und/oder "_{MsgAuthTagCorrector}"
 
 <section>
   <h2>Übungsbetrieb
@@ -108,14 +127,18 @@ hier die wichtigsten Neuerungen.
     <dt .deflist__dt> Lösungshinweise
     <dd .deflist__dd>
       Zusätzlich zu Aufgabe und Lösung können Hinweise ab einem
-      Datum vor Abgabfrist freigeschaltet werden,
+      Datum vor Ende des Abgabezeitraums freigeschaltet werden,
       z.B. Lösungen zu Präsenzaufgaben.
 
     <dt .deflist__dt> Sichtbarkeit
     <dd .deflist__dd>
-      Übungsblätter können bis zu einem Datum vor den Teilnehmern versteckt werden.
       <p>
-        Die Aufgabenstellung ist erst mit Eröffnung der Abgabe erhältlich,
+        Übungsblätter können bis zu einem Datum "Sichtabr ab" vor allen Teilnehmern versteckt werden.
+        Das kann nützlich sein, um Tutoren und Korrektoren ein provisorisches Übungsblatt verfügbar zu machen,
+        dessen Bewertungsmodalitäten und Fristen sich noch ändern können.
+      <p>
+        Erst wenn das Blatt sichtbar wird, sehen die Teilnehmer in Ihrer Übersichtsliste.
+        Alle Dateien zur Aufgabenstellung sind aber erst mit Beginn des Abgabezeitraums erhältlich,
         so wie bisher in UniWorX auch.
 
     <dt .deflist__dt> Zeitstempel
@@ -173,4 +196,4 @@ hier die wichtigsten Neuerungen.
       Planmäßige Wartungen werden ohne Ankündigung
       immer um 2:00h nachts durchgeführt.
       Es wird daher empfohlen, keine kritischen Abgabefristen
-      um oder kurz nach dieser Zeit einzustellen.
+      um oder kurz nach dieser Zeit einzustellen.

templates/profileData.hamlet

@@ -7,7 +7,7 @@
         <dt .deflist__dt> _{MsgMatrikelNr}
         <dd .deflist__dd> #{matnr}
       <dt .deflist__dt> _{MsgEMail}
-      <dd .deflist__dd> #{display userEmail}
+      <dd .deflist__dd> #{mailtoHtml userEmail}
       <dt .deflist__dt> _{MsgIdent}
       <dd .deflist__dd> #{display userIdent}
       <dt .deflist__dt> _{MsgLastLogin}
@@ -17,7 +17,7 @@
         $nothing
           _{MsgNever}
     $if not $ null admin_rights
-      <dt .deflist__dt> Administrator
+      <dt .deflist__dt>_{MsgAdminFor}
       <dd .deflist__dd>
         <ul .list-ul>
           $forall (E.Value institute) <- admin_rights
@@ -25,7 +25,7 @@
               <a href=@{SchoolShowR $ SchoolKey institute}>
                 #{display institute}
     $if not $ null lecturer_rights
-      <dt .deflist__dt> Lehrberechtigt
+      <dt .deflist__dt>_{MsgLecturerFor}
       <dd .deflist__dd>
         <ul .list-ul>
           $forall (E.Value institute) <- lecturer_rights
@@ -45,13 +45,12 @@
         <div .scrolltable>
           <table .table.table--striped.table--hover.table--condensed>
             <tr .table__row>
-              <th .table__th> Studiengang
+              <th .table__th>_{MsgStudyTerm}
-              <th .table__th> Abschluss
+              <th .table__th>_{MsgStudyFeatureDegree}
-              <th .table__th> Studienart
+              <th .table__th>_{MsgStudyFeatureType}
-              <th .table__th> Semester
+              <th .table__th>_{MsgStudyFeatureAge}
-              <th .table__th> Aktiv
+              <th .table__th>_{MsgStudyFeatureValid}
-              <th .table__th> Update
+              <th .table__th>_{MsgStudyFeatureUpdate}
-
 
             $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
               $with _ <- notUsedT studyFeaturesUser
@@ -115,20 +114,28 @@
     <a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
     .
 
-  <h2>
+
-        ^{modal "Alle Benutzerbezogenen Daten löschen" (Right delWdgt)}
+  <section>
-  <p>
+    <h2>_{MsgRemarks}
-    <h4>Hinweise:
     <ul>
       <li>
-        Sichern Sie Ihre Daten! Während des Testbetriebs von Uni2work
+        Sichern Sie bitte Ihre Daten! Die Uni2work Datenbank wird täglich gesichert;
-        könnten Daten unabsichtlich unwidderuflich gelöscht werden.
+        dennoch können wir Probleme während des Testbetriebs noch nicht gänzlich ausschließen.
       <li>
         Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Übungsgruppenleiterschaft, Raumbuchungen, etc.
       <li>
-        Benutzerdaten bleiben so lange gespeichert, bis ein Institutsadministrator über die Exmatrikulation informiert wurde. Dann wird der Account gelöscht.
+        Sie können die
-        Abgaben/Bonuspunkte werden unwiderruflich gelöscht.
+        <a href=@{HelpR}>
-        Klausurnoten verbleiben aus statistischen Gründen anonymisiert im System.
+          Löschung Ihre Daten über eine Supportanfrage beantragen
+        . Ihre Daten werden dann nach Ablauf einer Frist gelöscht.
+        Daten, welche keiner gesetzlichen Aufbewahrungsfrist unterliegen
+        (z.B. Klausurnoten) verbleiben im System bis zur Ablauf der Aufbewahrungsfrist.
+        <p>
+        Benutzerdaten bleiben prinzipiell so lange gespeichert,
+        bis ein Institutsadministrator über die Exmatrikulation informiert wurde.
+        Dann wird der Account mit einer angemessenen zeitverzögerung gelöscht.
+        Anonymisierte Klausurnoten verbleiben aus statistischen Gründen dauerhaft im System.
+
       <li>
         Bei gemeinsamen Gruppenabgaben wird nur die Zuordnung zu diesem Benutzer gelöscht.
         Die Abgabe selbst wird erst gelöscht, wenn alle Benutzer einer Abgabe deren Löschung veranlasst haben.

templates/table/layout-filter-default.lucius

@@ -1,4 +1,3 @@
 .table-filter {
-  border-bottom: 1px solid #d3d3d3;
   margin-bottom: 13px;
 }

templates/versionHistory.hamlet

@@ -7,7 +7,7 @@
     <h2>
       Bekannte Bugs
     <h3>
-      Stand: Februar 2019
+      Stand: März 2019
     <ul>
       <li>
         Login ist u.U. anders als im alten System, z.B. momentan geht nur <span style="font-family:monospace">@campus.lmu.de</span> aber nicht die Abkürzung <span style="font-family:monospace">@lmu.de</span>

templates/widgets/aform/aform.hamlet

@@ -3,7 +3,7 @@ $newline never
 $case formLayout
   $of FormDBTablePagesize
     $forall view <- fieldViews
-      <label .form-group__label.label-pagesize for=#{fvId view}>#{fvLabel view}
+      <label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
       ^{fvInput view}
   $of _
     $forall view <- fieldViews
@@ -13,10 +13,11 @@ $case formLayout
       $else
         <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
           $if not (Blaze.null $ fvLabel view)
-            <label .form-group__label for=#{fvId view}>
+            <label .form-group-label for=#{fvId view}>
-              #{fvLabel view}
+              <span .form-group-label__caption>
+                #{fvLabel view}
               $maybe hint <- fvTooltip view
-                <div .form-group__hint>^{hint}
+                <div .form-group-label__hint>^{hint}
           <div .form-group__input>
             ^{fvInput view}
             $maybe err <- fvErrors view

templates/widgets/data-delete/data-delete.hamlet

@@ -1,15 +1,21 @@
 <h2>
-  Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
+  Sind Sie sich absolut sicher
+  Benutzer ^{nameEmailWidget userEmail userDisplayName userSurname} zu löschen?
 <p>
-    Während der Testphase von Uni2work können Sie hiermit
+    Während der Testphase von Uni2work
-    Ihren Account bei Uni2work vollständig löschen.
+    werden Benutzer hiermit vollständig aus der Live-Datenbank mit
-    Mit Ihrem Campus-Account können Sie sich aber danach
+    <code>DELETE CASCADE uid
-    jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
+    gelöscht.
+    Klausurdaten müssen jedoch unbedingt 5 Jahre bis nach Exmatrikulation
+    aufbewahrt werden!
+<p>
+    Benutzer können sich mit Ihrem Campus-Account
+    natürlich jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
 <p>
     Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
-    wenn die Dateien ausschließlich Ihnen zugeordnet sind.
+    wenn die Dateien ausschließlich diesem Benutzer zugeordnet waren.
     Dateien aus Gruppenabgaben werden also erst dann gelöscht,
-    wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
+    wenn die Accounts alle Gruppenmitglieder gelöscht wurden.
 <p>
     <em>Achtung:
     Auch abgegebene Hausübungen werden gelöscht!
@@ -18,9 +24,4 @@
     (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
     Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
     auch nicht mehr rekonstruiert/berücksichtigt werden.)
-<p>
-  <em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
-  eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
-  aufbewahrt werden müssen.
-
 ^{btnForm}

templates/widgets/form/form.hamlet

@@ -1,17 +1,19 @@
 $newline never
 $# Wrapper for all kinds of forms
-<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
+<section>
-  $# Distinguish different falvours of submit button layouts here:
+  <form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
-  $case formSubmit
+    $# Distinguish different falvours of submit button layouts here:
-    $of FormNoSubmit
+    $case formSubmit
-      ^{formWidget}
+      $of FormNoSubmit
-    $of FormSubmit
+        ^{formWidget}
-      ^{formWidget}
+      $of FormSubmit
-      ^{submitButtonView}
+        ^{formWidget}
-    $of FormDualSubmit
+        ^{submitButtonView}
-      ^{submitButtonView}
+      $of FormDualSubmit
-      ^{formWidget}
+        ^{submitButtonView}
-      ^{submitButtonView}
+        ^{formWidget}
-    $of FormAutoSubmit
+        ^{submitButtonView}
-      <button type=submit data-autosubmit>
+      $of FormAutoSubmit
-        ^{btnLabel BtnSubmit}
+        ^{formWidget}
+        <button type=submit data-autosubmit>
+          ^{btnLabel BtnSubmit}

templates/widgets/massinput/list/cell.hamlet

@@ -0,0 +1,3 @@
+$newline never
+#{csrf}
+^{fvInput}

templates/widgets/modal/modal.hamlet

@@ -1,4 +1,5 @@
-<div .modal.js-modal #modal-#{modalId} data-trigger=#{triggerId} data-closeable :modalDynamic:data-dynamic>
+$newline never
+<div .modal.js-modal #modal-#{modalId'} data-trigger=#{triggerId'} data-closeable :isDynamic:data-dynamic>
   $case modalContent
     $of Right content
       <div .modal__content>

templates/widgets/modal/modal.julius

@@ -1,8 +1,5 @@
 document.addEventListener('DOMContentLoaded', function() {
-  var modalIdent = #{String modalId};
+  var modal = document.querySelector('#modal-' + #{String modalId'});
-  var selector = '#modal-' + modalIdent;
-  var modal = document.querySelector(selector);
-
   if (modal) {
     window.utils.setup('modal', modal);
   }

templates/widgets/modal/trigger.hamlet

@@ -0,0 +1,7 @@
+$newline never
+$maybe route <- mRoute
+  <a .modal__trigger href=#{route} ##{triggerId}>
+    <span .modal__trigger-label>^{modalTrigger'}
+$nothing
+  <div .modal__trigger ##{triggerId}>
+    <span .modal__trigger-label>^{modalTrigger'}

templates/widgets/navbar/item.hamlet

@@ -0,0 +1,3 @@
+<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
+  <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
+  <div .navbar__link-label>_{SomeMessage menuItemLabel}

templates/widgets/navbar/navbar.hamlet

@@ -8,34 +8,31 @@ $newline never
       <li .navbar__list-item.navbar__list-item--favorite>
         <a .navbar__link-wrapper href="#">
           <i .fas.fa-star>
-          <div .navbar__link-label> Favorites
+          <div .navbar__link-label>_{MsgNavigationFavourites}
 
-      $forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
+      $forall (menuItem@MenuItem{menuItemType, menuItemRoute, menuItemModal}, menuIdent, _) <- menuTypes
         $case menuItemType
           $of NavbarAside
             <li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
               $if menuItemModal
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+                ^{navbarModal (menuItem, menuIdent)}
-              <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
+              $else
-                <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
+                ^{navbarItem (menuItem, menuIdent)}
-                <div .navbar__link-label>_{SomeMessage menuItemLabel}
           $of _
 
     <ul .navbar__list.list--inline>
-      $forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
+      $forall (menuItem@MenuItem{menuItemType, menuItemRoute, menuItemModal}, menuIdent, _) <- menuTypes
         $case menuItemType
           $of NavbarRight
             <li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
               $if menuItemModal
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+                ^{navbarModal (menuItem, menuIdent)}
-              <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
+              $else
-                <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
+                ^{navbarItem (menuItem, menuIdent)}
-                <div .navbar__link-label>_{SomeMessage menuItemLabel}
           $of NavbarSecondary
             <li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
               $if menuItemModal
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+                ^{navbarModal (menuItem, menuIdent)}
-              <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
+              $else
-                <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
+                ^{navbarItem (menuItem, menuIdent)}
-                <div .navbar__link-label>_{SomeMessage menuItemLabel}
           $of _

templates/widgets/rating/rating.hamlet

@@ -1,8 +1,10 @@
 $# Display Rating, expects
+$#  sub :: Submission
+$#  submissionRatingDone :: Submission -> Bool
 $#  submissionRatingPoints :: Maybe points
 
-$maybe points <- submissionRatingPoints
+$if submissionRatingDone sub
-  $maybe grading <- preview _grading sheetType
+  $maybe (grading, points) <- mTuple (preview _grading sheetType) submissionRatingPoints
     $case grading
       $of Points{..}
         _{MsgAchievedOf points maxPoints}

test.sh

@@ -1,3 +1,3 @@
 #!/usr/bin/env bash
 
-exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}
+exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}

test/Database.hs

@@ -390,8 +390,8 @@ fillDb = do
   insert_ $ CourseEdit jost now ffp
   void . insert $ DegreeCourse ffp sdBsc sdInf
   void . insert $ DegreeCourse ffp sdMst sdInf
-  void . insert $ Lecturer jost   ffp
+  void . insert $ Lecturer jost   ffp CourseLecturer
-  void . insert $ Lecturer gkleen ffp
+  void . insert $ Lecturer gkleen ffp CourseAssistant
   adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
   insert_ $ SheetEdit gkleen now adhoc
   feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
@@ -421,7 +421,7 @@ fillDb = do
     }
   insert_ $ CourseEdit fhamann now eip
   void . insert' $ DegreeCourse eip sdBsc sdInf
-  void . insert' $ Lecturer fhamann eip
+  void . insert' $ Lecturer fhamann eip CourseLecturer
   -- interaction design
   ixd <- insert' Course
     { courseName = "Interaction Design (User Experience Design I & II)"
@@ -439,7 +439,7 @@ fillDb = do
     }
   insert_ $ CourseEdit fhamann now ixd
   void . insert' $ DegreeCourse ixd sdBsc sdInf
-  void . insert' $ Lecturer fhamann ixd
+  void . insert' $ Lecturer fhamann ixd CourseAssistant
   -- concept development
   ux3 <- insert' Course
     { courseName = "Concept Development (User Experience Design III)"
@@ -457,7 +457,7 @@ fillDb = do
     }
   insert_ $ CourseEdit fhamann now ux3
   void . insert' $ DegreeCourse ux3 sdBsc sdInf
-  void . insert' $ Lecturer fhamann ux3
+  void . insert' $ Lecturer fhamann ux3 CourseAssistant
   -- promo
   pmo <- insert' Course
     { courseName = "Programmierung und Modellierung"
@@ -475,7 +475,7 @@ fillDb = do
     }
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
-  void . insert $ Lecturer jost pmo
+  void . insert $ Lecturer jost pmo CourseAssistant
   void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMp)
@@ -534,5 +534,5 @@ fillDb = do
   insert_ $ CourseEdit gkleen now dbs
   void . insert' $ DegreeCourse dbs sdBsc sdInf
   void . insert' $ DegreeCourse dbs sdBsc sdMath
-  void . insert' $ Lecturer gkleen dbs
+  void . insert' $ Lecturer gkleen dbs CourseLecturer
-  void . insert' $ Lecturer jost   dbs
+  void . insert' $ Lecturer jost   dbs CourseAssistant

test/Model/TypesSpec.hs

@@ -140,6 +140,10 @@ instance Arbitrary AuthenticationMode where
   
   shrink AuthLDAP = []
   shrink (AuthPWHash _) = [AuthLDAP]
+
+instance Arbitrary LecturerType where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
   
 
 spec :: Spec
@@ -199,6 +203,8 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
     lawsCheckHspec (Proxy @AuthTagActive)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @LecturerType)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $