Merge from Master

.hlint.yaml

@@ -1,5 +1,5 @@
-# HLint configuration file                                                 
+# HLint configuration file
-# https://github.com/ndmitchell/hlint                                      
+# https://github.com/ndmitchell/hlint
 ##########################
 
   - ignore: { name: "Parse error" }
@@ -7,6 +7,7 @@
   - ignore: { name: "Use ||" }
   - ignore: { name: "Use &&" }
   - ignore: { name: "Use ++" }
+  - ignore: { name: "Use ***" }
 
   - arguments:
       - -XQuasiQuotes

ChangeLog.md

@@ -1,3 +1,7 @@
+  * Version 20.03.2019
+
+    Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)
+
   * Version 30.01.2019
 
     Designänderungen

RoleDescriptions.txt

@@ -0,0 +1,53 @@
+Most roles are school dependent, i.e. a lecturer for the Math-department can only create new lectures that have Math-department in their school field.
+
+
+Administrator for a school
+- top-level rights, can access everything other roles can within the same school
+- restrictions only apply to routes containing a different school; then no special rights are given
+- may appoint further administrators and lecturers for his school
+- all school-independent routes, such as help-requests and user-list are accessible
+- can impersonate any other user with lesser rights, i.e. lecturers within same school, all students, etc.
+- a user can be administrator for more than one school
+
+
+Lecturer for a school
+- can create courses for their school for all active terms
+- can view participants of his courses and record notes for participants
+- can create sheets for their courses
+- can view homework submissions for his courses, including marks and plain user-names
+- can mark homework
+- may appoint correctors for sheets belonging to his courses
+- may assign submitted homework to correctors
+- a user can be lecturer for more than one school
+- all rights correctors for his courses have
+
+
+Corrector for a sheet
+- may download their assigned anonymous homework submissions (submissions are identify through crypto-ids, no user-names)
+- may upload corrected and marked homework submissions for their assignments
+- may always download solution and sheet description files for their sheet, ignoring deadline constraints
+- may create homework submissions in the name of students (which identify themselves to the corrector by pseudonym; no association with real identity needed) for homework assignments which have their submission-mode set to "Submission external with pseudonym" by a lecturer
+
+
+Tutor for a tutorial of a course
+- yet unimplemented, likely similar to corrector; ie. can access sheets and solutions earlier than participants
+
+
+User (logged-in)
+- all logged-in users may use this role
+- no special school restrictions
+- may enroll in courses from any school; enrollment is associated with a field of study the user had at the time
+- may submit homework for marking in enrolled courses
+- all rights that not logged-in users have
+
+
+User (not logged-in)
+- can view course descriptions
+- can download course materials from courses that allow this for all un-enrolled users
+- can requests help from administrators
+- can log in with their campus-id creating a new user record in the process and elevating rights to "logged-in"
+
+
+
+Terminology:
+ - participants: a logged-in users that is enrolled in a specific course

build.sh

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

db.sh

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

messages/uniworx/de.msg

@@ -53,6 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
 CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
 CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
+CourseStudyFeature: Assoziiertes Hauptfach
+CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
@@ -69,9 +71,9 @@ CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
-CourseMembersCount num@Int64: #{display num}
+CourseMembersCount n@Int: #{display n}
-CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
+CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max}
-CourseMembersCountOf num@Int64 mbNum@Int64Maybe: #{display num} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"}
+CourseMembersCountOf n@Int mbNum@IntMaybe: #{display n} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"}
 CourseName: Name
 CourseDescription: Beschreibung
 CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@@ -88,6 +90,7 @@ CourseRegisterToTip: Anmeldung darf auch unbegrenzt offen bleiben
 CourseDeregisterUntilTip: Abmeldung darf auch unbegrenzt erlaubt bleiben
 CourseFilterSearch: Volltext-Suche
 CourseFilterRegistered: Registriert
+CourseFilterNone: Egal
 CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
 CourseDeleted: Kurs gelöscht
 CourseUserNote: Notiz
@@ -253,8 +256,10 @@ Theme: Oberflächen Design
 Favoriten: Anzahl gespeicherter Favoriten
 Plugin: Plugin
 Ident: Identifikation
+LastLogin: Letzter Login
 Settings: Individuelle Benutzereinstellungen
 SettingsUpdate: Einstellungen wurden gespeichert.
+Never: Nie
 
 MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
 
@@ -341,6 +346,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 
+AdminHeading: Administration
 AdminUserHeading: Benutzeradministration
 AccessRightsFor: Berechtigungen für
 AdminFor: Administrator
@@ -402,8 +408,28 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr
 
 SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
 
+AdminFeaturesHeading: Studiengänge
+StudyFeatureInference: Studiengangschlüssel-Inferenz
+StudyFeatureAge: Fachsemester
+StudyFeatureDegree: Abschluss
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
+NoPrimaryStudyField: (kein Hauptfach registriert)
+
+DegreeKey: Schlüssel Abschluss
+DegreeName: Abschluss
+DegreeShort: Abschlusskürzel
+StudyTermsKey: Schlüssel Studiengang
+StudyTermsName: Studiengang
+StudyTermsShort: Studiengangkürzel
+StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
+StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert
+StudyCandidateIncidence: Anmeldevorgang
+AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
+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
+StudyTermIsNew: Neu
 
 MailTestFormEmail: Email-Addresse
 MailTestFormLanguages: Spracheinstellungen
@@ -626,12 +652,12 @@ MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben bewerten
 MenuAuthPreds: Authorisierungseinstellungen
 
-AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate werden nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist (d.h. bis ihr Browser-Cookie abgelaufen ist).
+AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
-AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
+AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
 AuthTagDeprecated: Seite ist nicht überholt
 AuthTagDevelopment: Seite ist nicht in Entwicklung
 AuthTagLecturer: Nutzer ist Dozent
@@ -646,7 +672,7 @@ AuthTagOwner: Nutzer ist Besitzer
 AuthTagRated: Korrektur ist bewertet
 AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
-AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
+AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend
 

models/config

@@ -1,4 +1,6 @@
+-- Configuration settings shared among all uni2work-instances for interoperability (Users can seamlessly switch between uni2work-instances (load-balancing need not attach users to an instance persistently))
+-- Mostly cryptographic keys
 ClusterConfig
-    setting             ClusterSettingsKey
+    setting             ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ...
-    value               Value
+    value               Value              -- JSON-encoded value
     Primary setting

models/courses

@@ -1,50 +1,51 @@
-DegreeCourse json
+DegreeCourse json   -- for which degree programmes this course is appropriate for
     course       CourseId
     degree       StudyDegreeId
     terms        StudyTermsId
     UniqueDegreeCourse course degree terms
-Course
+Course    -- Information about a single course; contained info is always visible to all users
     name             (CI Text)
-    description      Html Maybe
+    description      Html Maybe    -- user-defined large Html, ought to contain module description
-    linkExternal     Text Maybe
+    linkExternal     Text Maybe    -- arbitrary user-defined url for external course page
-    shorthand        (CI Text)
+    shorthand        (CI Text)     -- practical shorthand of course name, used for identification
-    term             TermId
+    term             TermId        -- semester this course is taught
     school           SchoolId
-    capacity         Int64 Maybe
+    capacity         Int Maybe   -- number of allowed enrolements, if restricted
     -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
-    registerFrom     UTCTime Maybe
+    registerFrom     UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited
-    registerTo       UTCTime Maybe
+    registerTo       UTCTime Maybe -- enrolement may be prohibited from a given date onwards
-    deregisterUntil  UTCTime Maybe
+    deregisterUntil  UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
-    registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
+    registerSecret   Text Maybe    -- enrolement maybe protected by a simple common passphrase
-    materialFree     Bool
+    materialFree     Bool          -- False: only enrolled users may see course materials not stored in this table
-    TermSchoolCourseShort  term school shorthand
+    TermSchoolCourseShort  term school shorthand    -- shorthand must be unique within school and semester
-    TermSchoolCourseName   term school name
+    TermSchoolCourseName   term school name         -- name must be unique within school and semester
     deriving Generic
-CourseEdit
+CourseEdit                -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables)
     user         UserId
     time         UTCTime
     course       CourseId
-CourseFavourite
+CourseFavourite           -- which user accessed which course when, only displayed to user for convenience;
-    user         UserId
+    user         UserId   -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User"
-    time         UTCTime
+    time         UTCTime  -- oldest is removed first
     course       CourseId
     UniqueCourseFavourite user course
     deriving Show
-Lecturer
+Lecturer                       -- course ownership
     user         UserId
     course       CourseId
-    UniqueLecturer user course
+    UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
-CourseParticipant
+CourseParticipant                      -- course enrolement
     course       CourseId
     user         UserId
-    registration UTCTime
+    registration UTCTime               -- time of last enrolement for this course
+    field        StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
     UniqueParticipant user course
-CourseUserNote
+CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
     course       CourseId
     user         UserId
-    note         Text
+    note         Text          -- arbitrary user-defined text; visible only to lecturer of this course
     UniqueCourseUserNotes user course
-CourseUserNoteEdit
+CourseUserNoteEdit             -- who edited a participants course note whenl
     user         UserId
     time         UTCTime
     note         CourseUserNoteId

models/exams

@@ -1,4 +1,4 @@
--- EXAMS ARE TODO:
+-- EXAMS ARE TODO; THIS IS JUST AN UNUSED STUB
 Exam
     course              CourseId
     name                Text
@@ -8,8 +8,8 @@ Exam
     registrationBegin   UTCTime
     registrationEnd     UTCTime
     deregistrationEnd   UTCTime
-    ratingVisible       Bool
+    ratingVisible       Bool     -- may participants see their own rating yet
-    statisticsVisible   Bool
+    statisticsVisible   Bool     -- may participants view statistics over all participants (should not be allowed for 'small' courses)
 --ExamEdit
 --    user                UserId
 --    time                UTCTime

models/files

@@ -1,3 +1,6 @@
+-- Table storing all kinds of larges files as 8bit-byte vectors (regardless of encoding)
+-- PostgreSQL is intelligent enough to handle this in a sensible manner;
+-- helps to ensure consistency of database snapshots, no data is stored outside database
 File
     title           FilePath
     content         ByteString Maybe -- Nothing iff this is a directory

models/jobs

@@ -1,12 +1,17 @@
+-- Jobs to be executed as soon as possible in the background (so not to delay HTTP-responses, or triggered by cron-system without associated HTTP-Request)
 QueuedJob
-    content             Value
+    content             Value              -- JSON-encoded description of the work to be done (send an email to "test@example.org", find all recipients for a certain notifications and queue one new job each, distribute all submissions for a sheet to correctors, ...)
-    creationInstance    InstanceId
+    creationInstance    InstanceId         -- multiple uni2work-instances access the same database, record which instance created this job for debugging purposes
     creationTime        UTCTime
-    lockInstance        InstanceId Maybe
+    lockInstance        InstanceId Maybe   -- instance that has started to execute this job
-    lockTime            UTCTime Maybe
+    lockTime            UTCTime Maybe      -- time when execution had begun
     deriving Eq Read Show Generic Typeable
+
+-- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@
+-- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution)
+-- For the cron-system to determine whether a job needs to be done it needs to know if and when it was last (or ever) executed (i.e. a sheet's submissions should not be distributed twice)
 CronLastExec
-    job                 Value
+    job                 Value -- JSON-encoded description of work done
-    time                UTCTime
+    time                UTCTime -- When was the job executed
-    instance            InstanceId
+    instance            InstanceId -- Which uni2work-instance did the work
     UniqueCronLastExec job

models/rooms

@@ -1,3 +1,8 @@
+-- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB
+-- Idea is to create a selection of rooms that may be
+-- associated with exercise classes and exams
+-- offering links to the LMU Roomfinder
+-- and allow the creation of neat timetables for users
 Booking
     term        TermId
     begin       UTCTime
@@ -13,7 +18,8 @@ BookingEdit
 Room
     name        Text
     capacity    Int Maybe
-    building    Text Maybe
+    building    Text Maybe -- name of building
+    roomfinder  Text Maybe -- external url for LMU Roomfinder
 -- BookingRoom
 --    subject     RoomForId
 --    room        RoomId

models/schools

@@ -1,3 +1,5 @@
+-- Description of all primary schools managed by uni2work
+-- Each school must have a unique human-readable shorthand which is used as database row key
 School json
     name          (CI Text)
     shorthand     (CI Text)  -- SchoolKey :: SchoolShorthand -> SchoolId

models/sheets

@@ -1,39 +1,43 @@
-Sheet
+Sheet   -- exercise sheet for a given course
     course          CourseId
     name            (CI Text)
     description     Html Maybe
-    type            SheetType
+    type            SheetType        -- Does it count towards overall course grade?
-    grouping        SheetGroup
+    grouping        SheetGroup       -- May participants submit in groups of certain sizes?
-    markingText     Html Maybe
+    markingText     Html Maybe       -- Instructions for correctors, included in marking templates
-    visibleFrom     UTCTime Maybe
+    visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
-    activeFrom      UTCTime
+    activeFrom      UTCTime          -- Download of questions and submission is permitted afterwards
-    activeTo        UTCTime
+    activeTo        UTCTime          -- Submission is only permitted before
-    hintFrom        UTCTime Maybe
+    hintFrom        UTCTime Maybe    -- Additional files are made available
-    solutionFrom    UTCTime Maybe
+    solutionFrom    UTCTime Maybe    -- Solution is made available
-    uploadMode      UploadMode
+    uploadMode      UploadMode       -- Take apart Zip-Archives or not?
-    submissionMode  SheetSubmissionMode default='UserSubmissions'
+    submissionMode  SheetSubmissionMode default='UserSubmissions'  -- Submission upload by students or through tutors only?
-    autoDistribute  Bool default=false
+    autoDistribute  Bool default=false  -- Should correctors be assigned submissions automagically?
     CourseSheet course name
     deriving Generic
-SheetEdit
+SheetEdit                     -- who edited when a row in table "Course", kept indefinitely
     user            UserId
     time            UTCTime
     sheet           SheetId
+
+-- For anonoymous external submissions (i.e. paper submission tracked in uni2work)
+-- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created
+-- Chosen uniformly at random when the submitting user presses a button on the view of a sheet
 SheetPseudonym
     sheet           SheetId
-    pseudonym       Pseudonym
+    pseudonym       Pseudonym -- 24-bit number that should be attached to external submission (i.e. written on the submitted paper); encoded as two english words akin to PGP-Wordlist
     user            UserId
     UniqueSheetPseudonym sheet pseudonym
     UniqueSheetPseudonymUser sheet user
-SheetCorrector
+SheetCorrector                -- grant corrector role to user for a sheet
     user            UserId
     sheet           SheetId
-    load            Load
+    load            Load      -- portion of work that will be assigned to this corrector
-    state           CorrectorState default='CorrectorNormal'
+    state           CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
     UniqueSheetCorrector user sheet
     deriving Show Eq Ord
-SheetFile
+SheetFile                     -- a file that is part of an exercise sheet
     sheet           SheetId
     file            FileId
-    type            SheetFileType
+    type            SheetFileType   -- excercise, marking, hint or solution
     UniqueSheetFile file sheet type

models/submissions

@@ -1,34 +1,34 @@
-Submission
+Submission                        -- submission for marking by a CourseParticipant
     sheet           SheetId
-    ratingPoints    Points  Maybe -- "Just" does not mean done
+    ratingPoints    Points  Maybe -- "Just" does not mean done; not yet visible to participant
-    ratingComment   Text    Maybe -- "Just" does not mean done
+    ratingComment   Text    Maybe -- "Just" does not mean done; not yet visible to participant
     ratingBy        UserId  Maybe -- assigned corrector
-    ratingAssigned  UTCTime Maybe -- time assigned corrector
+    ratingAssigned  UTCTime Maybe -- time when corrector was assigned
-    ratingTime      UTCTime Maybe -- "Just" here indicates done!
+    ratingTime      UTCTime Maybe -- "Just" here indicates done; marking is made visible to participant
     deriving Show Generic
-SubmissionEdit
+SubmissionEdit                    -- user uploads new version of their submission
-    user            UserId
+    user            UserId        -- track id, important for group submissions
     time            UTCTime
     submission      SubmissionId
-SubmissionFile
+SubmissionFile                    -- files that are part of a submission
     submission      SubmissionId
     file            FileId
-    isUpdate        Bool         -- is this the file updated by a corrector (original will always be retained)
+    isUpdate        Bool          -- is this the file updated by a corrector (original will always be retained)
-    isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
+    isDeletion      Bool          -- only set if isUpdate is also set, but file was deleted by corrector
     UniqueSubmissionFile file submission isUpdate
     deriving Show
-SubmissionUser                   -- Actual submission participant
+SubmissionUser                    -- which submission belongs to whom
     user            UserId
     submission      SubmissionId
-    UniqueSubmissionUser user submission
+    UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups
-SubmissionGroup
+SubmissionGroup                   -- pre-defined submission groups; some courses only allow pre-defined submission groups
     course          CourseId
     name            Text Maybe
-SubmissionGroupEdit
+SubmissionGroupEdit               -- who edited a submissionGroup when?
     user            UserId
     time            UTCTime
     submissionGroup SubmissionGroupId
-SubmissionGroupUser              -- Registered submission groups, independent of actual SubmissionUser
+SubmissionGroupUser              -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser
     submissionGroup     SubmissionGroupId
     user                UserId
     UniqueSubmissionGroupUser submissionGroup   user

models/system-messages

@@ -1,12 +1,14 @@
+-- Messages shown to all users as soon as they visit the site/log in (i.e.: "System is going down for maintenance next sunday")
+-- Only administrators (of any school) should be able to create these via a web-interface
 SystemMessage
-    from                UTCTime Maybe
+    from                UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null)
-    to                  UTCTime Maybe
+    to                  UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null)
-    authenticatedOnly   Bool
+    authenticatedOnly   Bool -- Show message to all users upon visiting the site or only upon login?
-    severity            MessageClass
+    severity            MessageStatus -- Success, Warning, Error, Info, ...
-    defaultLanguage     Lang
+    defaultLanguage     Lang -- Language of @content@ and @summary@
-    content             Html
+    content             Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
     summary             Html Maybe
-SystemMessageTranslation
+SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers
     message             SystemMessageId
     language            Lang
     content             Html

models/terms

@@ -1,10 +1,13 @@
+-- Describes each term time.
+-- TermIdentifier is either W for Winterterm or S for Summerterm,
+-- followed by a two-digit year
 Term json
     name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
     start         Day            -- TermKey   :: TermIdentifier -> TermId
     end           Day
-    holidays      [Day]
+    holidays      [Day]          -- LMU holidays, for display in timetables
-    lectureStart  Day
+    lectureStart  Day            -- lectures usually start/end  later/earlier than the actual term,
-    lectureEnd    Day
+    lectureEnd    Day            -- used to generate warnings for lecturers creating unusual courses
-    active        Bool
+    active        Bool           -- may lecturers add courses to this term?
     Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
     deriving Show Eq Generic -- type TermId = Key Term

models/tutorials

@@ -1,7 +1,10 @@
+-- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB
+-- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs
 Tutorial json
     name        Text
     tutor       UserId
     course      CourseId
+    capacity    Int Maybe -- limit for enrolement in this tutorial
 TutorialUser
     user        UserId
     tutorial    TutorialId

models/users

@@ -1,43 +1,68 @@
-User json
+-- The files in /models determine the database scheme.
-    ident          (CI Text)
+-- The organisational split into several files has no operational effects.
-    authentication AuthenticationMode
+-- White-space and case matters: Each SQL table is named in 1st column of this file
-    matrikelnummer Text Maybe
+-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
-    email          (CI Text)
+-- Nullable columns have "Maybe" written after their type
-    displayName    Text
+-- Option "default=xyz" is only used for database migrations due to changes in the SQL-schema, also see Model.Migration
-    surname        Text            -- always use: nameWidget displayName surname
+-- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
-    maxFavourites  Int default=12
+-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
-    theme          Theme default='Default'
+--
-    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
+User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
-    dateFormat     DateTimeFormat "default='%d.%m.%Y'"
+    ident          (CI Text)                -- Case-insensitive user-identifier
-    timeFormat     DateTimeFormat "default='%R'"
+    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
-    downloadFiles  Bool default=false
+    lastAuthentication UTCTime Maybe        -- last login date
-    mailLanguages  MailLanguages default='[]'
+    matrikelnummer Text Maybe               -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
-    notificationSettings NotificationSettings
+    email          (CI Text)                -- Case-insensitive eMail address
-    UniqueAuthentication ident
+    displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
-    UniqueEmail email
+    surname        Text                     -- Display user names always through 'nameWidget displayName surname'
-    deriving Show Eq Generic
+    maxFavourites  Int default=12           -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
-UserAdmin
+    theme          Theme default='Default'  -- Color-theme of the frontend; user-defined
+    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
+    dateFormat     DateTimeFormat "default='%d.%m.%Y'"       -- preferred Date-only display format for user; user-defined
+    timeFormat     DateTimeFormat "default='%R'"             -- preferred Time-only display format for user; user-defined
+    downloadFiles  Bool default=false          -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
+    mailLanguages  MailLanguages default='[]'  -- Preferred language for eMail; i18n not yet implemented; user-defined
+    notificationSettings NotificationSettings  -- Bit-array for which events email notifications are requested by user; user-defined
+    UniqueAuthentication ident                 -- Column 'ident' can be used as a row-key in this table
+    UniqueEmail email                          -- Column 'email' can be used as a row-key in this table
+    deriving Show Eq Generic                   -- Haskell-specific settings for runtime-value representing a row in memory
+UserAdmin      -- Each row in this table grants school-specific administrator-rights to a specific user
     user   UserId
     school SchoolId
-    UniqueUserAdmin user school
+    UniqueUserAdmin user school       -- combination of user+school must be unique, i.e. no duplicate rows
-UserLecturer
+UserLecturer   -- Each row in this table grants school-specific lecturer-rights to a specific user
     user   UserId
     school SchoolId
-    UniqueSchoolLecturer user school
+    UniqueSchoolLecturer user school  -- combination of user+school must be unique, i.e. no duplicate rows
-StudyFeatures
+StudyFeatures  -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
     user          UserId
-    degree        StudyDegreeId
+    degree        StudyDegreeId   -- Abschluss, i.e. Master, Bachelor, etc.
-    field         StudyTermsId
+    field         StudyTermsId    -- Fach, i.e. Informatics, Philosophy, etc.
-    type          StudyFieldType
+    type          StudyFieldType  -- Major or minor, i.e. Haupt-/Nebenfach
     semester      Int
-    -- UniqueUserSubject user degree field -- There exists a counterexample
+    updated       UTCTime default='NOW()' -- last update from LDAP
-StudyDegree
+    valid         Bool default=true       -- marked as active in LDAP (students may switch, but LDAP never forgets)
-    key           Int
+    UniqueStudyFeatures user degree field type semester
-    shorthand     Text Maybe
+    -- UniqueUserSubject ubuser degree field -- There exists a counterexample
-    name          Text Maybe
+StudyDegree   -- Studienabschluss
-    Primary key
+    key           Int            -- LMU-internal key
-StudyTerms
+    shorthand     Text Maybe     -- admin determined shorthand
-    key           Int
+    name          Text Maybe     -- description given by LDAP
-    shorthand     Text Maybe
+    Primary key                  -- column key is used as actual DB row key
-    name          Text Maybe
+                                 -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
-    Primary key
+    deriving Show
+StudyTerms    -- Studiengang
+    key           Int            -- LMU-internal key
+    shorthand     Text Maybe     -- admin determined shorthand
+    name          Text Maybe     -- description given by LDAP
+    Primary key                  -- column key is used as actual DB row key
+                                 -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
+    deriving Show
+StudyTermCandidate    -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
+    -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
+    -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
+    -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
+    incidence     TermCandidateIncidence -- random id, generated once per login to associate matching pairs
+    key           Int      -- a possible key for the studyTermName
+    name          Text     -- studyTermName as plain text from LDAP
+    deriving Show Eq Ord

package.yaml

@@ -170,6 +170,7 @@ default-extensions:
 ghc-options:
   - -Wall
   - -fno-warn-type-defaults
+  - -fno-warn-unrecognised-pragmas
   - -fno-warn-partial-type-signatures
 
 when:

routes

@@ -38,6 +38,8 @@
 /users                        UsersR            GET           -- no tags, i.e. admins only
 /users/#CryptoUUIDUser        AdminUserR        GET POST      !development
 /users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
+/admin                        AdminR            GET
+/admin/features               AdminFeaturesR    GET POST
 /admin/test                   AdminTestR        GET POST
 /admin/errMsg                 AdminErrMsgR      GET POST
 

shell.nix

@@ -1,11 +1,8 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? null }:
+{ nixpkgs ? import <nixpkgs>, compiler ? null }:
 
 let
-  inherit (nixpkgs) pkgs;
+  inherit (nixpkgs {}) pkgs;
-
+  haskellPackages = if isNull compiler then pkgs.haskellPackages else pkgs.haskell.packages."${compiler}";
-  haskellPackages = if isNull compiler
-                       then pkgs.haskellPackages
-                       else pkgs.haskell.packages."${compiler}";
 
   drv = haskellPackages.callPackage ./uniworx.nix {};
 
@@ -26,21 +23,29 @@ let
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 
-      pgDir=$(mktemp -d)
+      if [[ -z "$PGHOST" ]]; then
-      pgSockDir=$(mktemp -d)
+        set -xe
-      pgLogFile=$(mktemp)
-      initdb --no-locale -D ''${pgDir}
-      pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700"
-      export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile}
-      psql -f ${postgresSchema} postgres
-      printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
 
-      cleanup() {
+        pgDir=$(mktemp -d)
-          pg_ctl stop -D ''${pgDir}
+        pgSockDir=$(mktemp -d)
-          rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
+        pgLogFile=$(mktemp)
-      }
+        initdb --no-locale -D ''${pgDir}
+        pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700"
+        export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile}
+        psql -f ${postgresSchema} postgres
+        printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
 
-      trap cleanup EXIT
+        cleanup() {
+            set +e -x
+            pg_ctl stop -D ''${pgDir}
+            rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
+            set +x
+        }
+
+        trap cleanup EXIT
+
+        set +xe
+      fi
 
       ${oldAttrs.shellHook}
     '';

src/CryptoID.hs

@@ -36,6 +36,7 @@ decCryptoIDs [ ''SubmissionId
              , ''SheetId
              , ''SystemMessageId
              , ''SystemMessageTranslationId
+             , ''StudyFeaturesId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Database/Esqueleto/Utils.hs

@@ -1,8 +1,19 @@
-module Database.Esqueleto.Utils where
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
-import ClassyPrelude.Yesod hiding (isInfixOf, (||.))
+module Database.Esqueleto.Utils
-import Data.Foldable as F
+  ( true, false
-import Database.Esqueleto as E
+  , isInfixOf, hasInfix
+  , any, all
+  , SqlIn(..)
+  , mkExactFilter, mkContainsFilter
+  , anyFilter
+  ) where
+
+import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
+import qualified Data.Set as Set
+import qualified Data.Foldable as F
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils.TH
 
 
 --
@@ -33,13 +44,52 @@ hasInfix = flip isInfixOf
 -- | Given a test and a set of values, check whether anyone succeeds the test
 --   WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated)
 any :: Foldable f =>
-  (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool)
+  (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-any test = F.foldr (\needle acc -> acc ||. test needle) false
+any test = F.foldr (\needle acc -> acc E.||. test needle) false
 
 -- | Given a test and a set of values, check whether all succeeds the test
 --   WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated)
 all :: Foldable f =>
-  (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool)
+  (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-all test = F.foldr (\needle acc -> acc &&. test needle) true
+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 sqlIJproj
+-- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
+-- 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                             -- ^ query row
+  -> Set.Set a                     -- ^ needle collection
+  -> E.SqlExpr (E.Value Bool)
+mkExactFilter lenslike row criterias
+  | Set.null criterias = true
+  | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
+
+-- | generic filter creation for dbTable
+--   Given a lens-like function, make filter searching for needles in String-like elements
+--   (Keep Set here to ensure that there are no duplicates)
+mkContainsFilter :: (E.SqlString a)
+  =>  (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
+  -> t                             -- ^ query row
+  -> Set.Set Text                  -- ^ needle collection
+  -> E.SqlExpr (E.Value Bool)
+mkContainsFilter lenslike row criterias
+  | Set.null criterias = true
+  | otherwise = any (hasInfix $ lenslike row) criterias
+
+
+anyFilter :: (Foldable f) => 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

src/Database/Esqueleto/Utils/TH.hs

@@ -0,0 +1,58 @@
+module Database.Esqueleto.Utils.TH
+  ( SqlIn(..)
+  , sqlInTuple, sqlInTuples
+  , sqlIJproj, sqlLOJproj
+  ) where
+
+import ClassyPrelude
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+
+import Database.Persist (PersistField)
+
+import Language.Haskell.TH
+
+import Data.List (foldr1, foldl)
+
+import Utils.TH
+
+class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
+  sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
+
+instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
+  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
+
+sqlInTuples :: [Int] -> DecsQ
+sqlInTuples = mapM sqlInTuple
+
+sqlInTuple :: Int -> DecQ
+sqlInTuple arity = do
+  tyVars <- replicateM arity $ newName "t"
+  vVs <- replicateM arity $ newName "v"
+  xVs <- replicateM arity $ newName "x"
+  xsV <- newName "xs"
+
+  let
+    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
+    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
+
+  instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
+    [ funD 'sqlIn
+      [ clause [tupP $ map varP xVs, varP xsV]
+        ( guardedB
+          [ normalGE [e|null $(varE xsV)|] [e|E.val False|]
+          , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
+          ]
+        ) []
+      ]
+    ]
+
+-- | 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)
+sqlIJproj :: Int -> Int -> ExpQ
+sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
+
+sqlLOJproj :: Int -> Int -> ExpQ
+sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin

src/Foundation.hs

@@ -42,6 +42,8 @@ import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
+import Data.List (nubBy)
+
 import Data.Monoid (Any(..))
 
 import Data.Pool
@@ -171,7 +173,7 @@ noneOneMoreDE num noneText singularForm pluralForm
   | otherwise = pluralForm
 
 -- Convenience Type for Messages
-type Int64Maybe = Maybe Int64 -- Yesod messages cannot deal with compound type identifiers
+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
@@ -226,7 +228,7 @@ instance RenderMessage UniWorX MsgLanguage where
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
 
-embedRenderMessage ''UniWorX ''MessageClass ("Message" <>)
+embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
 embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''StudyFieldType id
 embedRenderMessage ''UniWorX ''SheetFileType id
@@ -1027,6 +1029,7 @@ siteLayout' headingOverride widget = do
       addScript $ StaticR js_utils_asidenav_js
       addScript $ StaticR js_utils_asyncForm_js
       addScript $ StaticR js_utils_asyncTable_js
+      addScript $ StaticR js_utils_asyncTableFilter_js
       addScript $ StaticR js_utils_checkAll_js
       addScript $ StaticR js_utils_httpClient_js
       addScript $ StaticR js_utils_form_js
@@ -1038,9 +1041,13 @@ siteLayout' headingOverride widget = do
       addStylesheet $ StaticR css_utils_alerts_scss
       addStylesheet $ StaticR css_utils_asidenav_scss
       addStylesheet $ StaticR css_utils_asyncForm_scss
+      addStylesheet $ StaticR css_utils_asyncTable_scss
+      addStylesheet $ StaticR css_utils_asyncTableFilter_scss
+      addStylesheet $ StaticR css_utils_checkbox_scss
       addStylesheet $ StaticR css_utils_form_scss
       addStylesheet $ StaticR css_utils_inputs_scss
       addStylesheet $ StaticR css_utils_modal_scss
+      addStylesheet $ StaticR css_utils_radio_scss
       addStylesheet $ StaticR css_utils_showHide_scss
       addStylesheet $ StaticR css_utils_tabber_scss
       addStylesheet $ StaticR css_utils_tooltip_scss
@@ -1078,9 +1085,12 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
 instance YesodBreadcrumbs UniWorX where
   breadcrumb (AuthR _)        = return ("Login"        , Just HomeR)
   breadcrumb HomeR            = return ("Uni2work"     , Nothing)
-  breadcrumb UsersR           = return ("Benutzer"     , Just HomeR)
+  breadcrumb UsersR           = return ("Benutzer"     , Just AdminR)
-  breadcrumb AdminTestR       = return ("Test"         , Just HomeR)
   breadcrumb (AdminUserR _)   = return ("Users"        , Just UsersR)
+  breadcrumb AdminR           = return ("Administration", Nothing)
+  breadcrumb AdminFeaturesR   = return ("Test"         , Just AdminR)
+  breadcrumb AdminTestR       = return ("Test"         , Just AdminR)
+  breadcrumb AdminErrMsgR     = return ("Test"         , Just AdminR)
 
   breadcrumb InfoR            = return ("Information"  , Nothing)
   breadcrumb InfoLecturerR    = return ("Veranstalter" , Just InfoR)
@@ -1108,10 +1118,12 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)
   breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
   --         (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 CEditR)     = return ("Editieren"  , Just $ CourseR tid ssh csh CShowR)
-  breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",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 SheetListR) = return ("Übungen"  , 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 SheetNewR ) = return ("Neu",       Just $ CourseR tid ssh csh SheetListR)
+  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)
 
   breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
   breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit",    Just $ CSheetR tid ssh csh shn SShowR)
@@ -1133,7 +1145,7 @@ instance YesodBreadcrumbs UniWorX where
     return $ if
       | mayList   -> ("Statusmeldung", Just MessageListR)
       | otherwise -> ("Statusmeldung", Just HomeR)
-  breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR)
+  breadcrumb (MessageListR) = return ("Statusmeldungen", Just AdminR)
   breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
 
 submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
@@ -1252,6 +1264,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , menuItemModal = False
       , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
       }
+  , return MenuItem
+      { menuItemType  = NavbarAside
+      , menuItemLabel = MsgAdminHeading
+      , menuItemIcon  = Just "screwdriver"
+      , menuItemRoute = SomeRoute AdminR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 
 
@@ -1273,33 +1293,75 @@ pageActions (HomeR) =
       , menuItemAccessCallback' = return True
       }
   ,  MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
-      , menuItemLabel = MsgMenuAdminTest
+      , menuItemLabel = MsgAdminHeading
       , menuItemIcon  = Just "screwdriver"
-      , menuItemRoute = SomeRoute AdminTestR
+      , menuItemRoute = SomeRoute AdminR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ,  MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgAdminFeaturesHeading
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminFeaturesR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuMessageList
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute MessageListR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   , MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuAdminErrMsg
-      , menuItemIcon = Nothing
+      , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute AdminErrMsgR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (AdminR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgAdminFeaturesHeading
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminFeaturesR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgErrMsgHeading
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminErrMsgR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuUsers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute UsersR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
+      { menuItemType  = PageActionSecondary
+      , menuItemLabel = MsgMenuAdminTest
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminTestR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (InfoR) = [
     MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgInfoLecturerTitle
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute InfoLecturerR
@@ -1920,6 +1982,8 @@ instance YesodAuth UniWorX where
         $(widgetFile "login")
 
     authenticate Creds{..} = runDB $ do
+      now <- liftIO getCurrentTime
+
       let
         userIdent = CI.mk credsIdent
         uAuth = UniqueAuthentication userIdent
@@ -1947,7 +2011,12 @@ instance YesodAuth UniWorX where
                   return $ ServerError "LDAP lookup failed"
             ]
 
-        acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+        acceptExisting = do
+          res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+          case res of
+            Authenticated uid
+              | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
+            _other -> return res
 
       $logDebugS "auth" $ tshow Creds{..}
       UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
@@ -1966,6 +2035,7 @@ instance YesodAuth UniWorX where
             userAuthentication
               | isPWHash  = error "PWHash should only work for users that are already known"
               | otherwise = AuthLDAP
+            userLastAuthentication = now <$ guard (not isDummy)
 
           userEmail <- if
             | Just [bs] <- userEmail'
@@ -2006,16 +2076,18 @@ instance YesodAuth UniWorX where
               , userMailLanguages        = def
               , ..
               }
-            userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer
+            userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
-                          , UserDisplayName    =. userDisplayName
+                          , UserDisplayName        =. userDisplayName
-                          , UserSurname        =. userSurname
+                          , UserSurname            =. userSurname
-                          , UserEmail          =. userEmail
+                          , UserEmail              =. userEmail
-                          ]
+                          ] ++
+                          [ UserLastAuthentication =. Just now | not isDummy ]
 
           userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
+          studyTermCandidateIncidence <- liftIO getRandom
 
           let
-            userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
+            userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
             userStudyFeatures' = do
               (k, v) <- ldapData
               guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
@@ -2023,15 +2095,28 @@ instance YesodAuth UniWorX where
               Right str <- return $ Text.decodeUtf8' v'
               return str
 
+            termNames = nubBy ((==) `on` CI.mk) $ do
+              (k, v) <- ldapData
+              guard $ k == Attr "dfnEduPersonFieldOfStudyString"
+              v' <- v
+              Right str <- return $ Text.decodeUtf8' v'
+              return str
+
           fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
 
-          lift $ deleteWhere [StudyFeaturesUser ==. userId]
+          let
+            studyTermCandidates = do
+              studyTermCandidateName <- termNames
+              StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs
+              return StudyTermCandidate{..}
+          lift $ insertMany_ studyTermCandidates
 
-          forM_ fs $ \StudyFeatures{..} -> do
+          lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
+          forM_ fs $ \f@StudyFeatures{..} -> do
             lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
             lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+            void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
 
-          lift $ insertMany_ fs
           return $ Authenticated userId
         Nothing -> acceptExisting
 

src/Handler/Admin.hs

@@ -1,25 +1,47 @@
 module Handler.Admin where
 
 import Import
-import Handler.Utils
 import Jobs
-
+import Handler.Utils
 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Writer (mapWriterT)
+
+import Utils.Lens
 
 -- import Data.Time
--- import qualified Data.Text as T
+import qualified Data.Text as Text
 -- import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
 import Database.Persist.Sql (fromSqlKey)
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils as E
+
+import Handler.Utils.Table.Cells
+import qualified Handler.Utils.TermCandidates as Candidates
 
 -- import Colonnade hiding (fromMaybe)
 -- import Yesod.Colonnade
 
 -- import qualified Data.UUID.Cryptographic as UUID
 
+
+
+
+getAdminR :: Handler Html
+getAdminR = -- do
+   siteLayoutMsg MsgAdminHeading $ do
+      setTitleI MsgAdminHeading
+      [whamlet|
+        This shall become the Administrators' overview page.
+        Its current purpose is to provide links to some important admin functions
+      |]
+
 -- BEGIN - Buttons needed only here
 data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
@@ -34,7 +56,7 @@ instance Button UniWorX ButtonCreate where
 
   btnClasses CreateMath = [BCIsButton, BCInfo]
   btnClasses CreateInf  = [BCIsButton, BCPrimary]
--- END Button needed here
+-- END Button needed only here
 
 emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
 emailTestForm = (,)
@@ -55,7 +77,7 @@ emailTestForm = (,)
       SelFormatTime -> t
 
 makeDemoForm :: Int -> Form (Int,Bool,Double)
-makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
+makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
     (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
         <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
         <*  aformSection MsgFormBehaviour
@@ -76,23 +98,20 @@ makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used i
 getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
 getAdminTestR = postAdminTestR
 postAdminTestR = do
-  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
   case btnResult of
     (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
     (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
     FormMissing -> return ()
     _other -> addMessage Warning "KEIN Knopf erkannt"
 
-  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
+  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
-  case emailResult of
+  formResultModal emailResult AdminTestR $ \(email, ls) -> do
-    (FormSuccess (email, ls)) -> do
+    jId <- mapWriterT runDB $ do
-      jId <- runDB $ do
+      jId <- queueJob $ JobSendTestEmail email ls
-        jId <- queueJob $ JobSendTestEmail email ls
+      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
-        addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+      return jId
-        return jId
+    writeJobCtl $ JobCtlPerform jId
-      writeJobCtl $ JobCtlPerform jId
-    FormMissing -> return ()
-    (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
 
   let emailWidget' = [whamlet|
         <form method=post action=@{AdminTestR} enctype=#{emailEnctype} data-ajax-submit>
@@ -155,3 +174,160 @@ postAdminErrMsgR = do
       <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
         ^{ctView}
     |]
+
+
+-- BEGIN - Buttons needed only for StudyTermCandidateManagement
+data ButtonInferStudyTerms = ButtonInferStudyTerms
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonInferStudyTerms
+instance Finite ButtonInferStudyTerms
+
+nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
+
+instance Button UniWorX ButtonInferStudyTerms where
+  btnLabel   ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
+  btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
+-- END Button needed only here
+
+getAdminFeaturesR, postAdminFeaturesR :: Handler Html
+getAdminFeaturesR = postAdminFeaturesR
+postAdminFeaturesR = do
+    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
+    (infConflicts,infAccepted) <- case btnResult of
+      (FormSuccess ButtonInferStudyTerms) -> do
+        (infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler
+        unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous
+        unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant
+        if null infAccepted
+          then addMessageI Info    MsgNoCandidatesInferred
+          else addMessageI Success $ MsgCandidatesInferred $ length infAccepted
+        return (infConflicts,infAccepted)
+      _other -> (,[]) <$> runDB Candidates.conflicts
+    unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n
+
+    (   (degreeResult,degreeTable)
+      , (studyTermsResult,studytermsTable)
+      , ((),candidateTable)) <- runDB $ (,,)
+      <$> mkDegreeTable
+      <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
+      <*> mkCandidateTable
+
+    let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
+        degreeResult' = degreeResult <&> getDBFormResult
+          (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
+                   , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
+          ))
+        updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
+    formResult degreeResult' $ \res -> do
+      void . runDB $ Map.traverseWithKey updateDegree res
+      addMessageI Success MsgStudyDegreeChangeSuccess
+
+    let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text))
+        studyTermsResult' = studyTermsResult <&> getDBFormResult
+          (\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
+                   , row ^. _dbrOutput . _entityVal . _studyTermsShorthand
+          ))
+        updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
+    formResult studyTermsResult' $ \res -> do
+      void . runDB $ Map.traverseWithKey updateStudyTerms res
+      addMessageI Success MsgStudyTermsChangeSuccess
+
+    siteLayoutMsg MsgAdminFeaturesHeading $ do
+      setTitleI MsgAdminFeaturesHeading
+      $(widgetFile "adminFeatures")
+  where
+    textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
+      (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
+        <$> mopt textField "" (Just $ row ^. lensDefault)
+      )
+
+
+    mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
+    mkDegreeTable =
+      let dbtIdent      = "admin-studydegrees" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree))
+          dbtSQLQuery   = return
+          dbtRowKey     = (E.^. StudyDegreeKey)
+          dbtProj       = return
+          dbtColonnade  = formColonnade $ mconcat
+            [ sortable (Just "key")   (i18nCell MsgDegreeKey)   (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
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"  , SortColumn (E.^. StudyDegreeKey))
+            , ("name" , SortColumn (E.^. StudyDegreeName))
+            , ("short", SortColumn (E.^. StudyDegreeShorthand))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def { dbParamsFormAddSubmit = True
+                              , dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
+                              }
+          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+      in dbTable psValidator DBTable{..}
+
+    mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
+    mkStudytermsTable newKeys =
+      let dbtIdent      = "admin-studyterms" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
+          dbtSQLQuery   = return
+          dbtRowKey     = (E.^. StudyTermsKey)
+          dbtProj       = return
+          dbtColonnade  = formColonnade $ mconcat
+            [ sortable (Just "key")   (i18nCell MsgStudyTermsKey)   (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
+            , sortable (Just "isnew") (i18nCell MsgStudyTermIsNew)  (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , 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)))
+            , ("name"  , SortColumn (E.^. StudyTermsName))
+            , ("short" , SortColumn (E.^. StudyTermsShorthand))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def { dbParamsFormAddSubmit = True
+                              , dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+                              }
+          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+      in dbTable psValidator DBTable{..}
+
+    mkCandidateTable =
+      let dbtIdent      = "admin-termcandidate" :: Text
+          dbtStyle      = def { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
+          dbtSQLQuery   = return
+          dbtRowKey     = (E.^. StudyTermCandidateId)
+          dbtProj       = return
+          dbtColonnade  = dbColonnade $ mconcat
+            [ dbRow
+            , sortable (Just "key")       (i18nCell MsgStudyTermsKey)           (numCell  . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
+            , sortable (Just "name")      (i18nCell MsgStudyTermsName)          (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
+            , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"      , SortColumn (E.^. StudyTermCandidateKey))
+            , ("name"     , SortColumn (E.^. StudyTermCandidateName))
+            , ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
+            ]
+          dbtFilter     = Map.fromList
+            [ ("key",       FilterColumn $ mkExactFilter    (E.^. StudyTermCandidateKey))
+            , ("name",      FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
+            , ("incidence", FilterColumn $ mkExactFilter    (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
+            ]
+          dbtFilterUI mPrev = mconcat
+            -- [ prismAForm (singletonFilter "key")       mPrev $ aopt intField            (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
+            [ prismAForm (singletonFilter "key")       mPrev $ aopt (searchField False) (fslI MsgStudyTermsKey)
+            , prismAForm (singletonFilter "name")      mPrev $ aopt (searchField False) (fslI MsgStudyTermsName)
+            , prismAForm (singletonFilter "incidence") mPrev $ aopt (searchField False) (fslI MsgStudyCandidateIncidence)
+            ]
+          dbtParams     = def
+          psValidator   = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
+      in dbTable psValidator DBTable{..}
+

src/Handler/Corrections.hs

@@ -85,22 +85,22 @@ submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission)
 
 
 -- Columns
-colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
         $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
           -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
           textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
 
-colSchool :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
           $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
             anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
 
-colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
         $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
 
-colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
         $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
           let tid   = course ^. _3
@@ -109,16 +109,16 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
               shn   = sheetName $ entityVal sheet
           in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
 
-colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
         $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
 
-colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
   DBRow{ dbrOutput = (_, _, _, Nothing  , _) } -> cell mempty
   DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
 
-colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
         $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
           let csh = course ^. _2
@@ -134,7 +134,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
 colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
 colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
 
-colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
   csh = course ^. _2
   tid = course ^. _3
@@ -146,7 +146,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
       Just p  -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
   in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
-colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
   protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
   in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
@@ -170,26 +170,26 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
          scribe (_2 :: Lens' (a, SheetTypeSummary) SheetTypeSummary) summary
      ]
 
-colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
   maybe mempty dateTimeCell submissionRatingAssigned
 
-colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
   maybe mempty dateTimeCell submissionRatingTime
 
-colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
     lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
       cell [whamlet|#{review _PseudonymText pseudo}|]
   in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
-colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
+colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
 colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
 
-colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
+colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
 colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
@@ -197,7 +197,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
       _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
-colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
+colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
 colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
@@ -223,7 +223,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
           E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
-          E.orderBy [E.asc $ user E.^. UserDisplayName]
+          E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
           submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
@@ -237,6 +237,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
       [ ( "term"
         , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
         )
+      , ( "school"
+        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool
+        )
       , ( "course"
         , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
         )
@@ -263,7 +266,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
             E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
               E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
               E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
-              E.orderBy [E.asc $ user E.^. UserSurname]
+              E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
               E.limit 1
               return (user E.^. UserSurname)
         )
@@ -350,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = _1
+      , dbParamsFormIdent = def
       }
     -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
     -- gradingSummary <- do
@@ -611,13 +615,13 @@ postCorrectionR tid ssh csh shn cid = do
                                 (fslpI MsgRatingPoints "Punktezahl")
                                 (Just submissionRatingPoints)
 
-      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
+      ((corrResult, corrForm), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
         <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
         <*> pointsForm
         <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
         <* submitButton
 
-      ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
+      ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
             areq (zipFileField True) (fslI MsgRatingFiles) Nothing
         <*  submitButton
 
@@ -690,7 +694,7 @@ getCorrectionUserR tid ssh csh shn cid = do
 getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
-  ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
+  ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
        areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
     <* submitButton
 

src/Handler/Course.hs

@@ -5,14 +5,19 @@ module Handler.Course where
 import Import
 
 import Utils.Lens
+import Utils.Form
 -- import Utils.DB
 import Handler.Utils
-import Handler.Utils.Table.Cells
 import Handler.Utils.Course
 import Handler.Utils.Delete
+import Handler.Utils.Database
+import Handler.Utils.Table.Cells
+import Handler.Utils.Table.Columns
+import Database.Esqueleto.Utils
+import Database.Esqueleto.Utils.TH
 
 -- import Data.Time
-import qualified Data.Text as T
+-- import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
@@ -26,9 +31,9 @@ import qualified Database.Esqueleto as E
 
 
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
-type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
+type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
 
-colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
@@ -46,12 +51,12 @@ colDescription = sortable Nothing mempty
               Nothing      -> mempty
               (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
 
-colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
 
--- colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+-- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 -- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
 --           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
 --             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
@@ -65,48 +70,48 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
 --                   |]
 --             )
 
-colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
 
-colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
             anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
 
-colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
             anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
 
-colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             maybe mempty dateTimeCell courseRegisterFrom
             -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
 
-colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             maybe mempty dateTimeCell courseRegisterTo
 
-colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
               Nothing -> MsgCourseMembersCount currentParticipants
               Just limit -> MsgCourseMembersCountLimited currentParticipants limit
 
-colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
           $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered
 
 type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
 
-course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64)
+course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
 course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
     E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-    return (E.countRows :: E.SqlExpr (E.Value Int64))
+    return (E.countRows :: E.SqlExpr (E.Value Int))
 
 course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
 course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
@@ -263,8 +268,8 @@ getTermCourseListR tid = do
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do
+  (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do
-    [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
+    [(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
             E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
@@ -273,57 +278,82 @@ getCShowR tid ssh csh = do
             E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                  E.&&. course E.^. CourseSchool    E.==. E.val ssh
                  E.&&. course E.^. CourseShorthand E.==. E.val csh
+            E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
             let numParticipants = E.sub_select . E.from $ \part -> do
                   E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
-                  return ( E.countRows :: E.SqlExpr (E.Value Int64))
+                  return ( E.countRows :: E.SqlExpr (E.Value Int))
-            return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration)
+            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
       E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
       E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
-      return $ user E.^. UserDisplayName
+      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
-    return (course,schoolName,participants,registered,map E.unValue lecturers)
+      return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
+    return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers)
+
   mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
   mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
   mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
-  mRegAt   <- traverse (formatTime SelFormatDateTime)   registered
+  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
+  (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
   siteLayout (toWgt $ courseName course) $ do
     setTitleI $ prependCourseTitle tid ssh csh (""::Text)
     $(widgetFile "course")
 
+-- | Registration button with maybe a userid if logged in
+-- , maybe existing features if already registered
+-- , maybe some default study features
+-- , maybe a course secret
+registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
+-- unfinished WIP: must take study features if registred and show as mforced field
+registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
+    -- secret fields
+    (msecretRes', msecretView) <- case msecret of
+      (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
+      _ -> return (Nothing,Nothing)
+    -- study features
+    (msfRes', msfView) <- case loggedin of
+      Nothing -> return (Nothing,Nothing)
+      Just _  -> bimap Just Just <$> case participant of
+        Just CourseParticipant{courseParticipantField=Just sfid}
+                -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
+        _other  -> mreq    (studyFeaturesPrimaryFieldFor [ ]    loggedin) (fslI MsgCourseStudyFeature
+                                                                 & setTooltip  MsgCourseStudyFeatureTooltip) (Just defSFid)
+    -- button de-/register
+    (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
 
-registerForm :: Bool -> Maybe Text -> Form Bool
+    let widget = $(widgetFile "widgets/register-form/register-form")
-registerForm registered msecret extra = do
+    let msecretRes | Just res <- msecretRes' = Just <$> res
-  (msecretRes', msecretView) <- case msecret of
+                   | otherwise               = FormSuccess Nothing
-    (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
+    let msfRes     | Just res <- msfRes'     = res
-    _ -> return (Nothing,Nothing)
+                   | otherwise               = FormSuccess Nothing
-  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+    -- checks that correct button was pressed, and ignores result of btnRes
-  let widget = $(widgetFile "widgets/register-form/register-form")
+    let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
-  let msecretRes | Just res <- msecretRes' = Just <$> res
+    return (formRes, widget)
-                 | otherwise               = FormSuccess Nothing
+  where
-  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
+    isRegistered = isJust participant
 
 
 postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 postCRegisterR tid ssh csh = do
   aid <- requireAuthId
-  (cid, course, registered) <- runDB $ do
+  (cid, course, registration) <- runDB $ do
       (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-      registered <- isJust <$> getBy (UniqueParticipant aid cid)
+      registration <- getBy (UniqueParticipant aid cid)
-      return (cid, course, registered)
+      return (cid, course, entityVal <$> registration)
-  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  let isRegistered  = isJust registration
-  case regResult of
+  ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
-    (FormSuccess codeOk)
+  formResult regResult $ \(mbSfId,codeOk) -> if
-      | registered -> do
+      | isRegistered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
           addMessageI Info MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO getCurrentTime
-          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
+          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
           when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
       | otherwise -> addMessageI Warning MsgCourseSecretWrong
-    _other -> return () -- TODO check this!
+  -- addMessage Info $ toHtml $ show regResult -- For debugging only
   redirect $ CourseR tid ssh csh CShowR
 
 
@@ -502,7 +532,7 @@ data CourseForm = CourseForm
         , cfShort      :: CourseShorthand
         , cfTerm       :: TermId
         , cfSchool     :: SchoolId
-        , cfCapacity   :: Maybe Int64
+        , cfCapacity   :: Maybe Int
         , cfSecret     :: Maybe Text
         , cfMatFree    :: Bool
         , cfRegFrom    :: Maybe UTCTime
@@ -528,7 +558,7 @@ courseToForm (Entity cid Course{..}) = CourseForm
     }
 
 makeCourseForm :: Maybe CourseForm -> Form CourseForm
-makeCourseForm template = identForm FIDcourse $ \html -> do
+makeCourseForm 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
 
@@ -621,25 +651,53 @@ validateCourse CourseForm{..} =
   ] ]
 
 
+
 --------------------
 -- CourseUserTable
 
-type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
-type UserTableWhere  = UserTableExpr -> E.SqlExpr (E.Value Bool)
+        `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
-type UserTableData   = DBRow (Entity User, E.Value UTCTime, E.Value (Maybe CourseUserNoteId))
+        `E.LeftOuterJoin`
+        (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
 
-forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
+-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-forceUserTableType = id
+-- forceUserTableType = id
 
-userTableQuery :: UserTableWhere -> UserTableExpr
+-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-   -> E.SqlQuery  ( E.SqlExpr (Entity User)
+-- This ought to ease refactoring the query
-                  , E.SqlExpr (E.Value UTCTime)
+queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
-                  , E.SqlExpr (E.Value (Maybe CourseUserNoteId)))
+queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
-userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do
+
+queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
+queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
+queryUserNote = $(sqlLOJproj 3 2)
+
+queryFeaturesStudy ::  UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryFeaturesStudy  = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
+
+queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
+queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
+
+queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
+queryFeaturesField  = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
+
+
+userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
+                                                          , E.SqlExpr (E.Value UTCTime)
+                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
+                                                          , StudyFeaturesDescription')
+userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
+  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
+  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
   E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
   E.on $         participant E.^. CourseParticipantUser  E.==. user E.^. UserId
-  E.where_ $ whereClause t
+  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
-  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId)
+  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
+
+
+type UserTableData   = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))
 
 instance HasEntity UserTableData User where
   hasEntity = _dbrOutput . _1
@@ -649,49 +707,89 @@ instance HasUser UserTableData where
   hasUser = _dbrOutput . _1 . _entityVal
 
 _userTableRegistration :: Lens' UserTableData UTCTime
-_userTableRegistration = _dbrOutput . _2 . _unValue
+_userTableRegistration = _dbrOutput . _2
 
 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
-_userTableNote = _dbrOutput . _3 . _unValue
+_userTableNote = _dbrOutput . _3
 
--- default Where-Clause
+_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
-courseIs :: CourseId -> UserTableWhere
+_userTableFeatures = _dbrOutput . _4
-courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid
+
+_rowUserSemester :: Traversal' UserTableData Int
+_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
 
 
 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
 colUserComment tid ssh csh =
-    sortable (Just "course-user-note") (i18nCell MsgCourseUserNote)
+    sortable (Just "note") (i18nCell MsgCourseUserNote)
-      $ \DBRow{ dbrOutput=(Entity uid _, _, E.Value mbNoteKey) } ->
+      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
         maybeEmpty mbNoteKey $ const $
           anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
   where
     courseLink = CourseR tid ssh csh . CUserR
 
-    --  makeCourseUserTable :: (ToSortable h, Functor h) =>
+colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-    --                          UserTableWhere
+colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
-    --                          -> Colonnade
+    foldMap numCell . preview _rowUserSemester
-    --                               h
-    --                               (DBRow
-    --                                  (Entity User, E.Value UTCTime,
-    --                                   E.Value (Maybe CourseUserNoteId)))
-    --                               (DBCell (HandlerT UniWorX IO) ())
-    --                          -> PSValidator (HandlerT UniWorX IO) ()
-    --                          -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
 
-makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget
+colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-makeCourseUserTable whereClause colChoices psValidator =
+colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
-  -- return [whamlet|TODO|] -- TODO
+    foldMap htmlCell . view (_userTableFeatures . _3)
+
+colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
+    foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3)
+
+colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
+    foldMap htmlCell . preview (_userTableFeatures . _2 . _Just)
+
+colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
+    foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
+
+makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
+makeCourseUserTable cid colChoices psValidator =
   -- -- psValidator has default sorting and filtering
   let dbtIdent     = "courseUsers" :: Text
-      dbtStyle     = def
+      dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
-      dbtSQLQuery  = userTableQuery whereClause
+      dbtSQLQuery  = userTableQuery cid
-      dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId
+      dbtRowKey    = queryUser >>> (E.^. UserId)
-      dbtProj      = return -- . dbrOutput -- NOT SURE
+      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
       dbtColonnade = colChoices
-      dbtSorting   = Map.fromList [] -- TODO
+      dbtSorting   = Map.fromList
-      dbtFilter    = Map.fromList [] -- TODO
+        [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
-      dbtFilterUI  = mempty -- TODO
+        , sortUserSurname     queryUser -- needed for initial sorting
+        , sortUserDisplayName queryUser -- needed for initial sorting
+        , sortUserEmail       queryUser
+        , sortUserMatriclenr  queryUser
+        , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+        , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+        , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+        , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+        , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+        , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+        , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+              E.sub_select . E.from $ \edit -> do
+                E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                return . E.max_ $ edit E.^. CourseUserNoteEditTime
+          )
+        ]
+      dbtFilter    = Map.fromList
+        [ fltrUserNameLink    queryUser
+        , fltrUserEmail       queryUser
+        , fltrUserMatriclenr  queryUser
+        , fltrUserNameEmail   queryUser
+        -- , ("course-user-degree", error "TODO") -- TODO
+        -- , ("course-user-field" , error "TODO") -- TODO
+        , ("course-user-semesternr", FilterColumn $ mkExactFilter $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+        -- , ("course-registration", error "TODO") -- TODO
+        -- , ("course-user-note", error "TODO") -- TODO
+        ]
+      dbtFilterUI mPrev = mconcat
+        [ fltrUserNameEmailUI  mPrev
+        , fltrUserMatriclenrUI mPrev
+        ]
       dbtParams    = def
   in dbTableWidget' psValidator DBTable{..}
 
@@ -700,22 +798,24 @@ getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCUsersR tid ssh csh = do
   (course, numParticipants, participantTable) <- runDB $ do
     let colChoices  = mconcat
-          [ colUserParticipantLink tid ssh csh
+          [ 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
-    Entity cid course <-  getBy404 $ TermSchoolCourseShort tid ssh csh
+    Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
-    participantTable <- makeCourseUserTable (courseIs cid) colChoices psValidator
+    participantTable <- makeCourseUserTable cid colChoices psValidator
     return (course, numParticipants, participantTable)
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
       headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
   siteLayout headingLong $ do
     setTitleI headingShort
-
     $(widgetFile "course-participants")
 
 

src/Handler/Home.hs

@@ -192,7 +192,7 @@ getImpressumR :: Handler Html
 getImpressumR = -- do
   siteLayoutMsg' MsgMenuImpressum $ do
     setTitleI MsgImpressumHeading
-    $(widgetFile "impressum")
+    $(i18nWidgetFile "imprint")
 
 
 -- | Hinweise zu Datenschutz und Aufbewahrungspflichten
@@ -200,7 +200,7 @@ getDataProtR :: Handler Html
 getDataProtR = -- do
   siteLayoutMsg' MsgMenuDataProt $ do
     setTitleI MsgDataProtHeading
-    $(widgetFile "data-protection-de")
+    $(i18nWidgetFile "data-protection")
 
 
 -- | Allgemeine Informationen
@@ -280,8 +280,7 @@ getInfoLecturerR :: Handler Html
 getInfoLecturerR =
   siteLayoutMsg' MsgInfoLecturerTitle $ do
     setTitleI MsgInfoLecturerTitle
-    -- TODO: Translation. This is simply too much for a simple message and too akwward to cut into bits. Create i18nWidgetFile tool.
+    $(i18nWidgetFile "info-lecturer")
-    $(widgetFile "infoLecturer")
 
 
 getAuthPredsR, postAuthPredsR :: Handler Html

src/Handler/Profile.hs

@@ -27,7 +27,7 @@ data SettingsForm = SettingsForm
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
-makeSettingForm template = identForm FIDsettings $ \html -> do
+makeSettingForm template = identifyForm FIDsettings $ \html -> do
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
         <$  aformSection MsgFormCosmetics
         <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
@@ -248,6 +248,8 @@ getProfileDataR = do
   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
+
   -- Delete Button
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
   defaultLayout $ do

src/Handler/Sheet.hs

@@ -90,7 +90,7 @@ getFtIdMap sId = do
   return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
 
 makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
-makeSheetForm msId template = identForm FIDsheet $ \html -> do
+makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
     oldFileIds <- (return.) <$> case msId of
       Nothing    -> return $ partitionFileType mempty
       (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
@@ -780,7 +780,7 @@ postSCorrR = getSCorrR
 getSCorrR tid ssh csh shn = do
   Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
 
-  ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs

src/Handler/Submission.hs

@@ -49,7 +49,7 @@ import System.FilePath
 
 
 makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
-makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
+makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
     let
       fileUploadForm = case uploadMode of
         NoUpload -> pure Nothing

src/Handler/SystemMessage.hs

@@ -35,7 +35,7 @@ postMessageR cID = do
 
   let
     mkForm = do
-      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
+      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
         $ SystemMessage
           <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
           <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
@@ -51,7 +51,7 @@ postMessageR cID = do
 
       modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
         cID' <- encrypt tId
-        runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
+        runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
           $ (,)
           <$> fmap (Entity tId)
               ( SystemMessageTranslation
@@ -64,7 +64,7 @@ postMessageR cID = do
 
       let modifyTranss = Map.map (view $ _1._1) modifyTranss'
 
-      ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
+      ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
         $ SystemMessageTranslation
           <$> pure smId
           <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
@@ -215,6 +215,7 @@ postMessageListR = do
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = id
+      , dbParamsFormIdent = def
       }
     , dbtIdent = "messages" :: Text
     }
@@ -246,7 +247,7 @@ postMessageListR = do
     FormSuccess (_, _selection) -- prop> null _selection
       -> addMessageI Error MsgSystemMessageEmptySelection
 
-  ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
+  ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
     <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
     <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
     <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing

src/Handler/Term.hs

@@ -145,7 +145,7 @@ getTermShowR = do
         , dbtIdent = "terms" :: Text
         }
       defaultLayout $ do
-        setTitle "Freigeschaltete Semester"
+        setTitleI MsgTermsHeading
         $(widgetFile "terms")
 
 getTermEditR :: Handler Html

src/Handler/Utils.hs

@@ -7,6 +7,13 @@ 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 qualified Data.CaseInsensitive as CI
+
+import Language.Haskell.TH (Q, Exp)
+-- import Language.Haskell.TH.Datatype
+
+import Text.Hamlet (shamletFile)
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -36,9 +43,16 @@ tidFromText = fmap TermKey . maybeRight . termFromText
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
 
+-- | toWidget-Version of @nameHtml@, for convenience
 nameWidget :: Text -> Text -> Widget
 nameWidget displayName surname = toWidget $ nameHtml displayName surname
 
+-- | toWidget-Version of @nameEmailHtml@, for convenience
+nameEmailWidget :: CI Text -> Text -> Text -> Widget
+nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
+
+-- | Show user's displayName, highlighting the surname if possible.
+--   Otherwise appends the surname in parenthesis
 nameHtml :: Text -> Text -> Html
 nameHtml displayName surname
   | null surname = toHtml displayName
@@ -56,6 +70,21 @@ nameHtml displayName surname
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
 
+-- | 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 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 (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 email = wrapMailto email $ toHtml email
 
 -- | Prefix a message with a short cours id,
 --   eg. for window title bars, etc.
@@ -87,3 +116,12 @@ warnTermDays tid times = do
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   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,
+--   which contains a file for each language,
+--   eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet
+i18nWidgetFile :: FilePath -> Q Exp
+i18nWidgetFile =
+  -- TODO write code to distinguish languages here
+  widgetFile . (</> "de")

src/Handler/Utils/Database.hs

@@ -1,6 +1,8 @@
 module Handler.Utils.Database
   ( getSchoolsOf
   , makeSchoolDictionaryDB, makeSchoolDictionary
+  , StudyFeaturesDescription'
+  , studyFeaturesQuery, studyFeaturesQuery'
   ) where
 
 import Import
@@ -29,3 +31,33 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from
   E.where_ $ urights E.^. uuser   E.==. E.val uid
   E.orderBy [E.asc $ school E.^.SchoolName]
   return $ school E.^. SchoolName
+
+
+-- | Sub-Query to retrieve StudyFeatures with their human-readable names
+studyFeaturesQuery :: E.Esqueleto query expr backend
+  => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
+  -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms)
+  -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms))
+studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
+  E.on $ terms    E.^. StudyTermsId    E.==. features E.^. StudyFeaturesField
+  E.on $ degree   E.^. StudyDegreeId   E.==. features E.^. StudyFeaturesDegree
+  E.on $ features E.^. StudyFeaturesId E.==. studyFeaturesId
+  return (features, degree, terms)
+
+type StudyFeaturesDescription' =
+  ( E.SqlExpr (Maybe (Entity StudyFeatures))
+  , E.SqlExpr (Maybe (Entity StudyDegree))
+  , E.SqlExpr (Maybe (Entity StudyTerms))
+  )
+
+-- | Variant of @studyFeaturesQuery@ to be used in outer joins
+--   Sub-Query to retrieve StudyFeatures with their human-readable names
+studyFeaturesQuery'
+  :: E.SqlExpr (E.Value (Maybe StudyFeaturesId)) -- ^ query is joined on this @Maybe StudyFeaturesId@
+  -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))
+  -> E.SqlQuery StudyFeaturesDescription'
+studyFeaturesQuery' studyFeatureId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
+  E.on $ terms    E.?. StudyTermsId    E.==. features E.?. StudyFeaturesField
+  E.on $ degree   E.?. StudyDegreeId   E.==. features E.?. StudyFeaturesDegree
+  E.on $ features E.?. StudyFeaturesId E.==. studyFeatureId
+  return (features, degree, terms)

src/Handler/Utils/Delete.hs

@@ -51,7 +51,7 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
     multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
 
 confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
-confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
+confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
   where
     addDeleteTargets :: Form a -> Form a
     addDeleteTargets form csrf = do

src/Handler/Utils/Form.hs

@@ -214,6 +214,47 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
 schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
+-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
+-- (too many special cases, hence not used in course registration anymore)
+studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
+studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
+    -- we need a join, so we cannot just use optionsPersistCryptoId
+    rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
+        E.on     $   feature E.^. StudyFeaturesField  E.==. field  E.^. StudyTermsId
+        E.on     $   feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
+        E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
+              E.||. isPrimaryActiveUserStudyFeature feature
+        return (feature E.^. StudyFeaturesId, degree, field)
+    mr <- getMessageRender
+    mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM procOptions rawOptions
+  where
+    isPrimaryActiveUserStudyFeature feature = case mbuid of
+      Nothing    -> E.val False
+      (Just uid) -> feature E.^. StudyFeaturesUser  E.==. E.val uid
+              E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
+              E.&&. feature E.^. StudyFeaturesType  E.==. E.val FieldPrimary
+
+    procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
+    procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
+      let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
+          stname = fromMaybe (tshow stid) (studyTermsShorthand  <|> studyTermsName )
+      cfid <- encrypt sfid
+      return Option
+        { optionDisplay = stname <> " (" <> dgname <> ")"
+        , optionInternalValue = Just sfid
+        , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
+        }
+
+    nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
+    nonEmptyOptions emptyOpt opts
+      | null opts = [ Option
+          { optionDisplay       = emptyOpt
+          , optionInternalValue = Nothing
+          , optionExternalValue = "NoPrimaryStudyField"
+          } ]
+      | otherwise = opts
+
+
 uploadModeField :: Field Handler UploadMode
 uploadModeField = selectField optionsFinite
 
@@ -481,6 +522,30 @@ secretJsonField = Field{..}
       |]
     fieldEnctype = UrlEncoded
 
+boolField :: ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             )
+          => Field m Bool
+boolField = Field
+      { fieldParse = \e _ -> return $ boolParser e
+      , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
+    , fieldEnctype = UrlEncoded
+    }
+  where
+    boolParser [] = Right Nothing
+    boolParser (x:_) = case x of
+      "" -> Right Nothing
+      "none" -> Right Nothing
+      "yes" -> Right $ Just True
+      "on" -> Right $ Just True
+      "no" -> Right $ Just False
+      "true" -> Right $ Just True
+      "false" -> Right $ Just False
+      t -> Left $ SomeMessage $ MsgInvalidBool t
+    showVal = either $ const False
+
+
+
 
 funcForm :: forall k v m.
             ( Finite k, Ord k
@@ -540,42 +605,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
-mforced :: (site ~ HandlerSite m, MonadHandler m)
-        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
-mforced Field{..} FieldSettings{..} val = do
-  tell fieldEnctype
-  name <- maybe newFormIdent return fsName
-  theId <- lift $ maybe newIdent return fsId
-  mr <- getMessageRender
-  let fsAttrs' = fsAttrs <> [("disabled", "")]
-  return ( FormSuccess val
-         , FieldView
-           { fvLabel = toHtml $ mr fsLabel
-           , fvTooltip = toHtml <$> fmap mr fsTooltip
-           , fvId = theId
-           , fvInput = fieldView theId name fsAttrs' (Right val) False
-           , fvErrors = Nothing
-           , fvRequired = False
-           }
-         )
-
-aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-        => Field m a -> FieldSettings site -> a -> AForm m a
-aforced field settings val = formToAForm $ second pure <$> mforced field settings val
-
-apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
--- ^ Pseudo required
-apreq f fs mx = formToAForm $ do
-  mr <- getMessageRender
-  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
-
-wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
-wpreq f fs mx = mFormToWForm $ do
-  mr <- getMessageRender
-  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
-
 multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
             => Map action (AForm (HandlerT UniWorX IO) a)
             -> Maybe action
@@ -630,5 +659,5 @@ formResultModal res finalDest handler = maybeT_ $ do
   if
     | isModal   -> sendResponse $ toJSON messages
     | otherwise -> do
-        forM_ messages $ \Message{..} -> addMessage messageClass messageContent
+        forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
         redirect finalDest

src/Handler/Utils/StudyFeatures.hs

@@ -8,12 +8,12 @@ import Text.Parsec
 import Text.Parsec.Text
 
 
-parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures]
+parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
-parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) ""
+parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
 
-  
+
-pStudyFeatures :: UserId -> Parser [StudyFeatures]
+pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
-pStudyFeatures studyFeaturesUser = do
+pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
   studyFeaturesDegree <- StudyDegreeKey' <$> pKey
   void $ string "$$"
 
@@ -28,11 +28,11 @@ pStudyFeatures studyFeaturesUser = do
       studyFeaturesType <- pType
       void $ char '!'
       studyFeaturesSemester <- decimal
-
+      let studyFeaturesValid = True
       return StudyFeatures{..}
 
   pStudyFeature `sepBy1` char '#'
-
+  
 pKey :: Parser Int
 pKey = decimal
 

src/Handler/Utils/Table/Cells.hs

@@ -9,6 +9,8 @@ import Data.Monoid (Any(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.Writer (WriterT)
 
+import Text.Blaze (ToMarkup(..))
+
 import Utils.Lens
 import Handler.Utils
 
@@ -35,15 +37,31 @@ writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
 maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
-maybeCell =flip foldMap
+maybeCell = flip foldMap
+
+htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
+htmlCell = cell . toWidget . toMarkup
+
+pathPieceCell :: (IsDBTable m a, PathPiece p) => p -> DBCell m a
+pathPieceCell = cell . toWidget . toPathPiece
+
+-- | execute a DB action that return a widget for the cell contents
+sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
+sqlCell act = mempty & cellContents .~ lift act
 
 
 ---------------------
 -- Icon cells
 
+-- | Maybe display a tickmark/checkmark icon
 tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell = cell . toWidget . hasTickmark
 
+-- | Maybe display a exclamation icon
+isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
+isNewCell = cell . toWidget . isNew
+
+-- | Maybe display comment icon linking a given URL or show nothing at all
 commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
 commentCell Nothing     = mempty
 commentCell (Just link) = anchorCell link icon
@@ -65,7 +83,8 @@ userCell :: IsDBTable m a => Text -> Text -> DBCell m a
 userCell displayName surname = cell $ nameWidget displayName surname
 
 emailCell :: IsDBTable m a => CI Text -> DBCell m a
-emailCell userEmail = cell $(widgetFile "widgets/link-email")
+emailCell email = cell $(widgetFile "widgets/link-email")
+  where linkText= toWgt email
 
 cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c
 cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname)
@@ -166,30 +185,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
-
---------------------------------
--- Generic Columns
--- reuse encourages consistency
---
--- if it works out, turn into its own module
--- together with filters and sorters
-
-
--- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
-colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a  (DBCell m c)
-colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
-
-colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a  (DBCell m c)
-colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
-
-colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
-colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
-  where
-    -- courseLink :: CryptoUUIDUser -> Route UniWorX
-    courseLink = CourseR tid ssh csh . CUserR
-
-colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
-colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
-
-colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
-colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail

src/Handler/Utils/Table/Columns.hs

@@ -0,0 +1,157 @@
+module Handler.Utils.Table.Columns where
+
+import Import
+
+-- import Data.CaseInsensitive (CI)
+-- import qualified Data.CaseInsensitive as CI
+
+-- import Data.Monoid (Any(..))
+-- import Control.Monad.Writer.Class (MonadWriter(..))
+-- import Control.Monad.Trans.Writer (WriterT)
+
+-- import Text.Blaze (ToMarkup(..))
+
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils as E
+
+import Utils.Lens
+import Handler.Utils
+import Handler.Utils.Table.Cells
+
+
+--------------------------------
+-- Generic Columns
+-- reuse encourages consistency
+--
+-- The constant string for sort/filter keys
+-- should never be mentioned outside of this module
+-- to ensure consistency!
+--
+-- Each section should have the following parts:
+--  * colXYZ  : column definitions plus variants
+--  * sortXYZ  : sorting definitions for these columns
+--  * fltrXYZ  : filter  definitions for these columns
+--  * additional helper, such as default sorting
+
+
+---------------
+-- User names
+
+-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
+colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a  (DBCell m c)
+colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
+
+colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a  (DBCell m c)
+colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
+
+colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
+colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
+
+-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
+--   TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
+--   see also @defaultSortingName@
+sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserName queryUser = ("user-name", SortColumn $ toSortKey . queryUser)
+  where toSortKey user = (user E.^. UserSurname) E.++. (user E.^. UserDisplayName)
+
+-- | Alias for sortUserName for consistency, since column comes in two variants
+sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserNameLink = sortUserName
+
+sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
+
+sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
+
+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-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)
+fltrUserNameLink = fltrUserName
+
+fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
+  where
+    queryName = queryUser >>> (E.^. UserDisplayName)
+
+fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
+  where
+    queryName = queryUser >>> (E.^. UserDisplayName)
+
+fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
+
+fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
+
+-- | Searche all names, i.e. DisplayName, Surname, EMail
+fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+   => (a -> E.SqlExpr (Entity User))
+   -> (d, FilterColumn t)
+fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
+    [ mkContainsFilter  $ queryUser >>> (E.^. UserDisplayName)
+    , mkContainsFilter  $ queryUser >>> (E.^. UserSurname)
+    , mkContainsFilter  $ queryUser >>> (E.^. UserEmail)
+    ]
+  )
+
+fltrUserNameLinkUI ::  Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserNameLinkUI = fltrUserNameUI
+
+fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserNameUI mPrev =
+  prismAForm (singletonFilter "user-name") mPrev $ aopt (searchField True) (fslI MsgCourseMembers)
+
+fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserNameEmailUI mPrev =
+  prismAForm (singletonFilter "user-name-email") mPrev $ aopt (searchField True) (fslI MsgCourseMembers)
+
+-------------------
+-- Matriclenumber
+colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
+
+sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
+
+fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer))
+
+fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserMatriclenrUI mPrev =
+  prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt (searchField False) (fslI MsgMatrikelNr)
+
+
+----------------
+-- User E-Mail
+colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
+
+sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
+
+fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+  => (a -> E.SqlExpr (Entity User))
+  -> (d, FilterColumn t)
+fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail))
+
+fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserEmailUI mPrev =
+  prismAForm (singletonFilter "user-email") mPrev $ aopt (searchField False) (fslI MsgEMail)
+
+

src/Handler/Utils/Table/Pagination.hs

@@ -39,6 +39,7 @@ import Utils.Lens.TH
 
 import Import hiding (pi)
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)
 
@@ -53,7 +54,7 @@ import Control.Monad.Trans.Maybe
 
 import Data.Foldable (Foldable(foldMap))
 
-import Data.Map (Map, (!))
+import Data.Map (Map)
 import qualified Data.Map as Map
 
 import qualified Data.Set as Set
@@ -89,9 +90,6 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode)
 import qualified Data.ByteString.Lazy as LBS
 
 
-$(sqlInTuples [2..16])
-
-
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
 data SortDirection = SortAsc | SortDesc
@@ -370,12 +368,12 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
 
 data DBTable m x = forall a r r' h i t k k'.
   ( ToSortable h, Functor h
-  , E.SqlSelect a r, SqlIn k k', DBTableKey k'
+  , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
-  , dbtRowKey :: t -> k
+  , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
   , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map SortingKey (SortColumn t)
@@ -461,6 +459,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x
 instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   def = DBParamsDB
 
+data DBParamsFormIdent where
+  DBParamsFormTableIdent :: DBParamsFormIdent
+  DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
+  DBParamsFormNoIdent :: DBParamsFormIdent
+
+instance Default DBParamsFormIdent where
+  def = DBParamsFormTableIdent
+
+unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
+unDBParamsFormIdent DBTable{dbtIdent}  DBParamsFormTableIdent       = Just $ toPathPiece dbtIdent
+unDBParamsFormIdent _                 (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
+unDBParamsFormIdent _                  DBParamsFormNoIdent          = Nothing
+
 instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
   data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
     { dbParamsFormMethod     :: StdMethod
@@ -470,6 +481,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
     , dbParamsFormAdditional :: Form a
     , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
     , dbParamsFormResult     :: Lens' x (FormResult a)
+    , dbParamsFormIdent      :: DBParamsFormIdent
     }
   type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
   -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
@@ -492,7 +504,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
   -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
-  runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
+  runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
+    = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
+    . dbParamsFormEvaluate
+    . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
+    . dbParamsFormWrap dbtParams
+    . maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
+    . addPIHiddenField dbtable pi
+    . addPreviousHiddenField dbtable pKeys
+    . withFragment
 
   dbInvalidateResult DBParamsForm{..} reason result = do
     reasonTxt <- getMessageRender <*> pure reason
@@ -510,6 +530,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
     , dbParamsFormAdditional = \_ -> return (pure (), mempty)
     , dbParamsFormEvaluate   = liftHandlerT . runFormPost
     , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
+    , dbParamsFormIdent      = def
     }
 
 dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
@@ -605,9 +626,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
 
   (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
-    (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
+    (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
 
-    (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
+    (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')
@@ -629,7 +650,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
       | otherwise
       = (, def) $ runPSValidator dbtable Nothing
-    psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
+    psSorting' = map (\SortingSetting{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting
 
   mapM_ (addMessageI Warning) errs
 
@@ -642,9 +663,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           -> do
             E.limit l
             E.offset (psPage * l)
-      Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps
+      Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
       _other  -> return ()
-    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
+    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
     return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
   let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
@@ -846,11 +867,11 @@ instance Ord i => Monoid (DBFormResult i a r) where
 getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
 
-formCell :: forall res r i a. (Ord i, Monoid res)
+formCell :: forall x r i a. (Ord i, Monoid x)
-         => Lens' res (FormResult (DBFormResult i a (DBRow r)))
+         => Lens' x (FormResult (DBFormResult i a (DBRow r)))   -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
-         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)          -- ^ generate row identfifiers for use in form result
          -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) res)
+         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
 formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
   { formCellAttrs    = []
   , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
@@ -873,11 +894,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
 dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
-dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
+dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
-         => Lens' res (FormResult (DBFormResult i a (DBRow r)))
+         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
          -> Setter' a Bool
          -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) res)
+         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
 dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
   where
     genForm _ mkUnique = do

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

@@ -6,8 +6,6 @@ module Handler.Utils.Table.Pagination.Types
   , sortable
   , ToSortable(..)
   , SortableP(..)
-  , SqlIn(..)
-  , sqlInTuples
   , DBTableInvalid(..)
   ) where
 
@@ -20,13 +18,6 @@ import Data.CaseInsensitive (CI)
 
 import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
 
-import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
-
-import Language.Haskell.TH
-
-import Data.List (foldr1, foldl)
-
 
 newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
   deriving (Show, Read, Generic)
@@ -67,38 +58,6 @@ instance ToSortable Headless where
   pSortable = Nothing
 
 
-class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
-  sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
-
-instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
-  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
-
-sqlInTuples :: [Int] -> DecsQ
-sqlInTuples = mapM sqlInTuple
-
-sqlInTuple :: Int -> DecQ
-sqlInTuple arity = do
-  tyVars <- replicateM arity $ newName "t"
-  vVs <- replicateM arity $ newName "v"
-  xVs <- replicateM arity $ newName "x"
-  xsV <- newName "xs"
-
-  let
-    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
-    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
-  
-  instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
-    [ funD 'sqlIn
-      [ clause [tupP $ map varP xVs, varP xsV]
-        ( guardedB
-          [ normalGE [e|null $(varE xsV)|] [e|E.val False|]
-          , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
-          ]
-        ) []
-      ]
-    ]
-
-
 data DBTableInvalid = DBTIRowsMissing Int
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 

src/Handler/Utils/TermCandidates.hs

@@ -0,0 +1,184 @@
+module Handler.Utils.TermCandidates where
+
+import Import
+-- import Handler.Utils
+
+
+-- Import this module as Candidates
+
+-- import Utils.Lens
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+-- import Yesod.Form.Bootstrap3
+-- import Colonnade hiding (fromMaybe)
+-- import Yesod.Colonnade
+-- import qualified Data.UUID.Cryptographic as UUID
+-- import Control.Monad.Trans.Writer (mapWriterT)
+-- import Database.Persist.Sql (fromSqlKey)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+
+import qualified Database.Esqueleto as E
+-- import Database.Esqueleto.Utils as E
+
+{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
+
+type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
+
+data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
+  deriving (Typeable, Show)
+
+instance Exception FailedCandidateInference
+  -- Default Instance
+
+-- -- | Just an heuristik to fill in defaults
+-- shortenStudyTerm :: Text -> Text
+-- shortenStudyTerm = concatMap (take 4) . splitCamel
+
+-- | Attempt to identify new StudyTerms based on observations, returning:
+--   * list of ambiguous instances that were discarded outright (identical names for differents keys observed in single incidences)
+--   * list of problems, ie. StudyTerms that contradict observed incidences
+--   * list of redundants, i.e. redundant observed incidences
+--   * list of accepted, i.e. newly accepted key/name pairs
+inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)])
+inferHandler = runDB $ inferAcc ([],[],[])
+  where
+    inferAcc (accAmbiguous, accRedundants, accAccepted) =
+      handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do
+        (infAmbis, infReds,infAccs) <- inferStep
+        if null infAccs
+          then return ([],          accAmbiguous, infReds ++ accRedundants,            accAccepted)
+          else do
+            E.transactionSave -- commit transaction if there are no problems
+            inferAcc   (infAmbis ++ accAmbiguous, infReds ++ accRedundants, infAccs ++ accAccepted)
+
+    inferStep = do
+      ambiguous  <- removeAmbiguous
+      redundants <- removeRedundant
+      accepted <- acceptSingletons
+      problems <- conflicts
+      unless (null problems) $ throwM $ FailedCandidateInference problems
+      return (ambiguous, redundants, accepted)
+
+{-
+Candidate 1 11 "A"
+Candidate 1 11 "B"
+Candidate 1 12 "A"
+Candidate 1 12 "B"
+Candidate 2 12 "B"
+Candidate 2 12 "C"
+Candidate 2 13 "B"
+Candidate 2 13 "C"
+
+should readily yield 11/A, 12/B 13/C:
+
+it can infer due to overlab that 12/B must be true, then eliminating B identifies A and C;
+this rests on the assumption that the Names are unique, which is NOT TRUE;
+as a fix we simply eliminate all observations that have the same name twice, see removeInconsistent
+
+-}
+
+-- | remove candidates with ambiguous observations,
+--   ie. candidates that have duplicated term names with differing keys
+--   which may happen in rare cases
+removeAmbiguous :: DB [TermCandidateIncidence]
+removeAmbiguous = do
+  ambiList <- E.select $ E.from $ \candidate -> do
+    E.groupBy ( candidate E.^. StudyTermCandidateIncidence
+              , candidate E.^. StudyTermCandidateKey
+              , candidate E.^. StudyTermCandidateName
+              )
+    E.having $ E.countRows E.!=. E.val (1 :: Int64)
+    return $ candidate E.^. StudyTermCandidateIncidence
+  let ambiSet = E.unValue <$> List.nub ambiList
+  -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
+  deleteWhere [StudyTermCandidateIncidence <-. ambiSet]
+  return ambiSet
+
+
+-- | remove known StudyTerm from candidates that have the _exact_ name,
+--   ie. if a candidate contains a known key, we remove it and its associated fullname
+--   only save if ambiguous candidates haven been removed
+removeRedundant :: DB [Entity StudyTermCandidate]
+removeRedundant = do
+  redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
+    E.on $  candidate E.^. StudyTermCandidateKey  E.==. sterm E.^. StudyTermsKey
+      E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
+    return candidate
+  -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
+  forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
+    deleteWhere $   ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
+                :  ([ StudyTermCandidateKey       ==. studyTermCandidateKey       ]
+                ||. [ StudyTermCandidateName      ==. studyTermCandidateName      ])
+  return redundants
+
+
+-- | Search for single candidates and memorize them as StudyTerms.
+--   Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy!
+--   Does not delete the used candidates, user @removeRedundant@ for this later on.
+--   Esqueleto does not provide the INTERESECT operator, thus
+--   we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
+acceptSingletons :: DB [(STKey,Text)]
+acceptSingletons = do
+  knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
+  -- let knownKeysSet = Set.fromAscList knownKeys
+  -- In case of memory problems, change next lines to conduit proper:
+  incidences <- fmap entityVal <$> selectList [StudyTermCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
+  -- incidences <- E.select $ E.from $ \candidate -> do
+  --   E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
+  --   return candidate
+
+  -- Possibly expensive pure computations follows. Break runDB to shorten transaction?
+  let groupedCandidates :: Map STKey (Map UUID (Set Text))
+      groupedCandidates = foldl' groupFun mempty incidences
+
+      -- given a key, map each incidence to set of possible names for this key
+      groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
+      groupFun m StudyTermCandidate{..} =
+        insertWith (Map.unionWith Set.union)
+                   studyTermCandidateKey
+                   (Map.singleton studyTermCandidateIncidence $ Set.singleton studyTermCandidateName)
+                   m
+
+      -- pointwise intersection per incidence gives possible candidates per key
+      keyCandidates :: Map STKey (Set Text)
+      keyCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
+
+      -- filter candidates having a unique possibility left
+      fixedKeys :: [(STKey,Text)]
+      fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
+
+      combFixed :: [(STKey,Text)] -> STKey -> Set Text ->  [(STKey,Text)]
+      combFixed acc k s | Set.size s == 1 -- possibly redundant
+                        , [n] <- Set.elems s = (k,n):acc
+                        -- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
+                        | otherwise = acc
+
+      -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
+      registerFixed :: (STKey, Text) -> DB ()
+      registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
+
+  -- register newly fixed candidates
+  forM_ fixedKeys registerFixed
+  return fixedKeys
+
+
+-- | all existing StudyTerms that are contradiced by current observations
+conflicts :: DB [Entity StudyTerms]
+conflicts = E.select $ E.from $ \studyTerms -> do
+  E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
+  E.where_ $ E.exists $ E.from $ \candidateOne -> do
+    E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
+    E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
+        E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
+        E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
+  return studyTerms
+
+
+

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -61,6 +61,9 @@ import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
 
+import System.Random as Import (Random)
+import Control.Monad.Random.Class as Import (MonadRandom(..))
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Model.hs

@@ -19,7 +19,9 @@ import Data.Aeson (Value)
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
 
-import Utils.Message (MessageClass)
+import Text.Blaze (ToMarkup, toMarkup, Markup)
+import Utils.Message (MessageStatus)
+
 import Settings.Cluster (ClusterSettingsKey)
 
 import Data.Binary (Binary)
@@ -41,3 +43,20 @@ deriving instance Binary (Key Term)
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime
+
+-- Do these instances belong here?
+instance ToMarkup StudyDegree where
+  toMarkup StudyDegree{..} = toMarkup $
+    fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
+
+shortStudyDegree :: StudyDegree -> Markup
+shortStudyDegree StudyDegree{..} = toMarkup $
+    fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
+
+instance ToMarkup StudyTerms where
+  toMarkup StudyTerms{..} = toMarkup $
+    fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
+
+shortStudyTerms :: StudyTerms -> Markup
+shortStudyTerms StudyTerms{..} = toMarkup $
+    fromMaybe (tshow studyTermsKey) studyTermsShorthand

src/Model/Migration.hs

@@ -207,6 +207,22 @@ customMigrations = Map.fromListWith (>>)
            UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points');
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|8.0.0|] [version|9.0.0|]
+    , whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do
+        [executeQQ|
+          ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id);
+          ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true;
+        |]
+        users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |]
+        forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
+    , do
+        whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -8,6 +8,7 @@ module Model.Types
   , module Numeric.Natural
   , module Mail
   , module Utils.DateTime
+  , module Data.UUID.Types
   ) where
 
 import ClassyPrelude
@@ -784,3 +785,4 @@ type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
+type TermCandidateIncidence = UUID

src/Settings.hs

@@ -39,7 +39,7 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
-import Utils hiding (MessageClass(..))
+import Utils hiding (MessageStatus(..))
 import Control.Lens
 
 import Data.Maybe (fromJust)

src/Utils.hs

@@ -24,8 +24,7 @@ import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
-import Control.Lens as Utils (none)
+import Utils.Parameters as Utils
-
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -33,13 +32,16 @@ import Data.Char (isDigit, isSpace)
 import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
 import Numeric (showFFloat)
 
-import Control.Lens
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
 -- import qualified Data.List as List
 
+import Control.Lens
+import Control.Lens as Utils (none)
+
+import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
@@ -159,6 +161,11 @@ hasTickmark :: Bool -> Markup
 hasTickmark True  = [shamlet|<i .fas .fa-check>|]
 hasTickmark False = mempty
 
+isNew :: Bool -> Markup
+isNew True  = [shamlet|<i .fas .fa-exclamation>|]
+isNew False = mempty
+
+
 ---------------------
 -- Text and String --
 ---------------------
@@ -320,6 +327,17 @@ mergeAttrs = mergeAttrs' `on` sort
 
 
 
+----------
+-- Sets --
+----------
+
+-- | Intersection of multiple sets. Returns empty set for empty input list
+setIntersections :: Ord a => [Set a] -> Set a
+setIntersections []    = Set.empty
+setIntersections (h:t) = foldl' Set.intersection h t
+
+
+
 ----------
 -- Maps --
 ----------
@@ -340,6 +358,17 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
 invertMap = groupMap . map swap . Map.toList
 
 
+---------------
+-- Functions --
+---------------
+
+-- curryN, uncurryN see Utils.TH
+
+-- | Just @flip (.)@ for convenient formatting in some cases,
+--   Deprecated in favor of Control.Arrow.(>>>)
+compose :: (a -> b) -> (b -> c) -> (a -> c)
+compose = flip (.)
+
 
 -----------
 -- Maybe --
@@ -473,8 +502,6 @@ throwExceptT :: ( Exception e, MonadThrow m )
              => ExceptT e m a -> m a
 throwExceptT = exceptT throwM return
 
-
-
 ------------
 -- Monads --
 ------------
@@ -574,32 +601,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 -- GET Parameters --
 --------------------
 
-data GlobalGetParam = GetReferer
+-- Moved to Utils.Parameters
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe GlobalGetParam
-instance Finite GlobalGetParam
-nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
-
-lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
-lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
-
-hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
-hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
-
-
-data GlobalPostParam = PostDeleteTarget
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe GlobalPostParam
-instance Finite GlobalPostParam
-nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
-
-lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
-lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
-
-hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
-hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
 
 ---------------------------------
 -- Custom HTTP Request-Headers --

src/Utils/Form.hs

@@ -2,9 +2,11 @@
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
+import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
 import Settings
 
+import Utils.Parameters
+
 -- import Text.Blaze (toMarkup) -- for debugging
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
@@ -18,6 +20,8 @@ import qualified Data.Map.Lazy as Map
 import qualified Data.Set as Set
 
 import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
 
 import Data.List ((!!))
 
@@ -194,6 +198,7 @@ addAutosubmit = addAttr "data-autosubmit" ""
 
 data FormIdentifier
   = FIDcourse
+  | FIDcourseRegister
   | FIDsheet
   | FIDsubmission
   | FIDsettings
@@ -209,7 +214,9 @@ data FormIdentifier
   | FIDSystemMessageAddTranslation
   | FIDDBTableFilter
   | FIDDBTablePagesize
+  | FIDDBTable
   | FIDDelete
+  | FIDCourseRegister
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -217,11 +224,32 @@ instance PathPiece FormIdentifier where
   toPathPiece = showToPathPiece
 
 
-identForm :: (Monad m, PathPiece ident)
+identifyForm' :: (Monad m, PathPiece ident, Eq ident)
-          => ident -- ^ Form identification
+              => Lens' x (FormResult a)
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+              -> ident -- ^ Form identification
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+              -> (Html -> MForm m (x, widget))
-identForm = identifyForm . toPathPiece
+              -> (Html -> MForm m (x, widget))
+identifyForm' resLens identVal form fragment = do
+    -- Create hidden <input>.
+    let fragment' =
+          [shamlet|
+            <input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
+            #{fragment}
+          |]
+
+    -- Check if we got its value back.
+    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
+    -- form, which will turn its result into FormMissing.  Also,
+    -- doing this avoids having lots of fields with red errors.
+    let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
+                    | otherwise    = id
+    fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
+
+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
@@ -512,4 +540,42 @@ prismAForm p outer form = review p <$> form inner
   where
     inner = outer >>= preview p
 
+---------------------------------------------
+-- Special variants of @mopt@, @mreq@, ... --
+---------------------------------------------
 
+mforced :: (site ~ HandlerSite m, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
+mforced Field{..} FieldSettings{..} val = do
+  tell fieldEnctype
+  name <- maybe newFormIdent return fsName
+  theId <- lift $ maybe newIdent return fsId
+  mr <- getMessageRender
+  let fsAttrs' = fsAttrs <> [("disabled", "")]
+  return ( FormSuccess val
+         , FieldView
+           { fvLabel = toHtml $ mr fsLabel
+           , fvTooltip = toHtml <$> fmap mr fsTooltip
+           , fvId = theId
+           , fvInput = fieldView theId name fsAttrs' (Right val) False
+           , fvErrors = Nothing
+           , fvRequired = False
+           }
+         )
+
+aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> AForm m a
+aforced field settings val = formToAForm $ second pure <$> mforced field settings val
+
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+-- ^ Pseudo required
+apreq f fs mx = formToAForm $ do
+  mr <- getMessageRender
+  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
+
+wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpreq f fs mx = mFormToWForm $ do
+  mr <- getMessageRender
+  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)

src/Utils/Lens.hs

@@ -80,6 +80,15 @@ makeLenses_ ''SheetType
 
 makePrisms ''AuthResult
 
+makeLenses_ ''StudyFeatures
+
+makeLenses_ ''StudyDegree
+
+makeLenses_ ''StudyTerms
+
+makeLenses_ ''StudyTermCandidate
+
+
 -- makeClassy_ ''Load
 
 

src/Utils/Message.hs

@@ -1,6 +1,6 @@
 module Utils.Message
-  ( MessageClass(..)
+  ( MessageStatus(..)
-  , UnknownMessageClass(..)
+  , UnknownMessageStatus(..)
   , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
   , Message(..)
   , messageI, messageIHamlet, messageFile, messageWidget
@@ -25,64 +25,64 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 
 
-data MessageClass = Error | Warning | Info | Success
+data MessageStatus = Error | Warning | Info | Success
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
 
-instance Universe MessageClass
+instance Universe MessageStatus
-instance Finite   MessageClass
+instance Finite   MessageStatus
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
-  } ''MessageClass
+  } ''MessageStatus
 
-nullaryPathPiece ''MessageClass camelToPathPiece
+nullaryPathPiece ''MessageStatus camelToPathPiece
-derivePersistField "MessageClass"
+derivePersistField "MessageStatus"
 
-newtype UnknownMessageClass = UnknownMessageClass Text
+newtype UnknownMessageStatus = UnknownMessageStatus Text
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-instance Exception UnknownMessageClass
+instance Exception UnknownMessageStatus
 
 
 data Message = Message
-  { messageClass :: MessageClass
+  { messageStatus :: MessageStatus
   , messageContent :: Html
   }
 
 instance Eq Message where
-  a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b
+  a == b = ((==) `on` messageStatus) a b && ((==) `on` renderHtml . messageContent) a b
 
 instance Ord Message where
-  a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b
+  a `compare` b = (compare `on` messageStatus) a b `mappend` (compare `on` renderHtml . messageContent) a b
 
 instance ToJSON Message where
   toJSON Message{..} = object
-    [ "class" .= messageClass
+    [ "status" .= messageStatus
     , "content" .= renderHtml messageContent
     ]
 
 instance FromJSON Message where
   parseJSON = withObject "Message" $ \o -> do
-    messageClass <- o .: "class"
+    messageStatus <- o .: "status"
     messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
     return Message{..}
 
 
-addMessage :: MonadHandler m => MessageClass -> Html -> m ()
+addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
 addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)
 
-addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
 addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
 
-messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message
+messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
-messageI messageClass msg = do
+messageI messageStatus msg = do
   messageContent <- toHtml . ($ msg) <$> getMessageRender
   return Message{..}
 
 addMessageIHamlet :: ( MonadHandler m
                      , RenderMessage (HandlerSite m) msg
                      , HandlerSite m ~ site
-                     ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
+                     ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m ()
 addMessageIHamlet mc iHamlet = do
   mr <- getMessageRender
   ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
@@ -90,22 +90,22 @@ addMessageIHamlet mc iHamlet = do
 messageIHamlet :: ( MonadHandler m
                   , RenderMessage (HandlerSite m) msg
                   , HandlerSite m ~ site
-                  ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message
+                  ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message
 messageIHamlet mc iHamlet = do
   mr <- getMessageRender
   Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)
 
-addMessageFile :: MessageClass -> FilePath -> ExpQ
+addMessageFile :: MessageStatus -> FilePath -> ExpQ
 addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
 
-messageFile :: MessageClass -> FilePath -> ExpQ
+messageFile :: MessageStatus -> FilePath -> ExpQ
 messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|]
 
 addMessageWidget :: forall m site.
                     ( MonadHandler m
                     , HandlerSite m ~ site
                     , Yesod site
-                    ) => MessageClass -> WidgetT site IO () -> m ()
+                    ) => MessageStatus -> WidgetT site IO () -> m ()
 -- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
 addMessageWidget mc wgt = do
   PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
@@ -115,7 +115,7 @@ messageWidget :: forall m site.
                  ( MonadHandler m
                  , HandlerSite m ~ site
                  , Yesod site
-                 ) => MessageClass -> WidgetT site IO () -> m Message
+                 ) => MessageStatus -> WidgetT site IO () -> m Message
 messageWidget mc wgt = do
   PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
   messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))

src/Utils/Parameters.hs

@@ -0,0 +1,78 @@
+module Utils.Parameters
+  ( GlobalGetParam(..)
+  , lookupGlobalGetParam, hasGlobalGetParam
+  , lookupGlobalGetParamForm, hasGlobalGetParamForm
+  , globalGetParamField
+  , GlobalPostParam(..)
+  , lookupGlobalPostParam, hasGlobalPostParam
+  , lookupGlobalPostParamForm, hasGlobalPostParamForm
+  , globalPostParamField
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Utils.PathPiece
+
+import qualified Data.Map as Map
+
+import Data.Universe
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+
+data GlobalGetParam = GetReferer
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe GlobalGetParam
+instance Finite GlobalGetParam
+nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
+
+lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
+lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
+
+hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
+hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
+
+
+lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
+lookupGlobalGetParamForm ident = runMaybeT $ do
+  ps <- MaybeT askParams
+  MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
+
+hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
+hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
+
+globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalGetParamField ident Field{fieldParse} = runMaybeT $ do
+  ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
+  fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
+  MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)
+
+data GlobalPostParam = PostFormIdentifier
+                     | PostDeleteTarget
+                     | PostMassInputShape
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe GlobalPostParam
+instance Finite GlobalPostParam
+nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
+
+lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
+lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
+
+hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
+hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
+
+lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
+lookupGlobalPostParamForm ident = runMaybeT $ do
+  ps <- MaybeT askParams
+  MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
+
+hasGlobalPostParamForm :: Monad m => GlobalPostParam -> MForm m Bool
+hasGlobalPostParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
+
+globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalPostParamField ident Field{fieldParse} = runMaybeT $ do
+  ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
+  fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
+  MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)

src/Utils/TH.hs

@@ -20,10 +20,25 @@ import Data.List ((!!), foldl)
 -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
 projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-projNI n i = lamE [pat] rhs
+projNI n i = do
-  where pat = tupP (map varP xs)
+  x <- newName "x"
-        rhs = varE (xs !! (i - 1))
+  let rhs = varE x
-        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
+  let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
+  lamE [pat] rhs
+
+
+-- | Generic projections N-tuples that are actually left-associative pairs
+--   i.e. @$(leftAssociativePairProjection c n m :: (..(t1 `c` t2) `c` .. `c` tn) -> tm@ (for m<=n)
+leftAssociativePairProjection :: Name -> Int -> Int -> ExpQ
+leftAssociativePairProjection constructor n i = do
+    x <- newName "x"
+    lamE [pat x n] (varE x)
+  where
+    pat x 1       = varP x
+    pat x w
+      | w==i      = conP constructor [wildP, varP x]
+      | otherwise = conP constructor [pat x (pred w), wildP]
+
 
 ---------------
 -- Functions --

stack.nix

@@ -1,8 +1,14 @@
-{ ghc, nixpkgs ? (import <nixpkgs> {}) }:
+{ ghc, nixpkgs ? import <nixpkgs> }:
 
 let
-  inherit (nixpkgs) haskell pkgs;
+  snapshot = "lts-10.5";
-  haskellPackages = if ghc.version == pkgs.haskellPackages.ghc.version then pkgs.haskellPackages else pkgs.haskell.packages."ghc${builtins.replaceStrings ["."] [""] ghc.version}";
+  stackage = import (fetchTarball {
+    url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz";
+    sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz";
+  });
+  inherit (nixpkgs { overlays = [ stackage."${snapshot}" ]; }) haskell pkgs;
+
+  haskellPackages = pkgs.haskell.packages."${snapshot}";
 in haskell.lib.buildStackProject {
   inherit ghc;
   name = "stackenv";

stack.yaml

@@ -17,6 +17,10 @@ packages:
       git: https://github.com/pngwjpgh/encoding.git
       commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
     extra-dep: true
+  - location:
+      git: https://github.com/pngwjpgh/memcached-binary.git
+      commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
+    extra-dep: true
 
 extra-deps:
   - colonnade-1.2.0
@@ -45,8 +49,4 @@ extra-deps:
   - quickcheck-classes-0.4.14
   - semirings-0.2.1.1
 
-  - memcached-binary-0.2.0
-
-allow-newer: true
-
 resolver: lts-10.5

start.sh

@@ -2,7 +2,7 @@
 
 unset HOST
 export DETAILED_LOGGING=true
-export LOG_ALL=true
+export LOG_ALL=false
 export LOGLEVEL=info
 export DUMMY_LOGIN=true
 export ALLOW_DEPRECATED=true

static/css/utils/asidenav.scss

@@ -57,7 +57,7 @@
       padding-left: 10px;
 
       &.js-show-hide__toggle::before {
-        top: 25px;
+        z-index: 1;
       }
     }
   }
@@ -103,7 +103,6 @@
     &::before {
       left: auto;
       right: 20px;
-      top: 30px;
       color: var(--color-font);
     }
   }
@@ -314,6 +313,10 @@
       word-break: break-all;
       background-color: var(--color-dark);
       color: var(--color-lightwhite);
+
+      &:hover {
+        background-color: var(--color-dark);
+      }
     }
 
     .asidenav__link-shorthand {

static/css/utils/asyncForm.scss

@@ -1,9 +1,78 @@
 .async-form-response {
   margin: 20px 0;
+  position: relative;
+  width: 100%;
+  font-size: 18px;
+  text-align: center;
+  padding-top: 60px;
+}
+
+.async-form-response::before,
+.async-form-response::after {
+  position: absolute;
+  top: 0px;
+  left: 50%;
+  display: block;
+}
+
+.async-form-response--success::before {
+  content: '';
+  width: 17px;
+  height: 28px;
+  border: solid #069e04;
+  border-width: 0 5px 5px 0;
+  transform: translateX(-50%) rotate(45deg);
+}
+
+.async-form-response--info::before {
+  content: '';
+  width: 5px;
+  height: 30px;
+  top: 10px;
+  background-color: #777;
+  transform: translateX(-50%);
+}
+.async-form-response--info::after {
+  content: '';
+  width: 5px;
+  height: 5px;
+  background-color: #777;
+  transform: translateX(-50%);
+}
+
+.async-form-response--warning::before {
+  content: '';
+  width: 5px;
+  height: 30px;
+  background-color: rgb(255, 187, 0);
+  transform: translateX(-50%);
+}
+.async-form-response--warning::after {
+  content: '';
+  width: 5px;
+  height: 5px;
+  top: 35px;
+  background-color: rgb(255, 187, 0);
+  transform: translateX(-50%);
+}
+
+.async-form-response--error::before {
+  content: '';
+  width: 5px;
+  height: 40px;
+  background-color: #940d0d;
+  transform: translateX(-50%) rotate(-45deg);
+}
+.async-form-response--error::after {
+  content: '';
+  width: 5px;
+  height: 40px;
+  background-color: #940d0d;
+  transform: translateX(-50%) rotate(45deg);
 }
 
 .async-form-loading {
   opacity: 0.1;
-  transition: opacity 800ms ease-in-out;
+  transition: opacity 800ms ease-out;
   pointer-events: none;
 }

static/css/utils/asyncTable.scss

@@ -0,0 +1,5 @@
+.async-table--loading {
+  opacity: 0.7;
+  pointer-events: none;
+  transition: opacity 400ms ease-out;
+}

static/css/utils/asyncTableFilter.scss

@@ -0,0 +1,5 @@
+.async-table-filter--loading {
+  opacity: 0.7;
+  pointer-events: none;
+  transition: opacity 400ms ease-out;
+}

static/css/utils/checkbox.scss

@@ -0,0 +1,74 @@
+
+/* CUSTOM CHECKBOXES */
+/* Completely replaces legacy checkbox */
+.checkbox {
+  position: relative;
+  display: inline-block;
+
+  [type="checkbox"] {
+    position: fixed;
+    top: -1px;
+    left: -1px;
+    width: 1px;
+    height: 1px;
+    overflow: hidden;
+  }
+
+  label {
+    display: block;
+    height: 24px;
+    width: 24px;
+    background-color: #f3f3f3;
+    box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05);
+    border: 2px solid var(--color-primary);
+    border-radius: 4px;
+    color: white;
+    cursor: pointer;
+  }
+
+  label::before,
+  label::after {
+    position: absolute;
+    display: block;
+    top: 12px;
+    left: 8px;
+    height: 2px;
+    width: 8px;
+    background-color: var(--color-font);
+  }
+
+  :checked + label {
+    background-color: var(--color-primary);
+  }
+
+  [type="checkbox"]:focus + label {
+    border-color: #3273dc;
+    box-shadow: 0 0 0 0.125em rgba(50,115,220,.25);
+    outline: 0;
+  }
+
+  :checked + label::before,
+  :checked + label::after {
+    content: '';
+  }
+
+  :checked + label::before {
+    background-color: white;
+    transform: rotate(45deg);
+    left: 4px;
+  }
+
+  :checked + label::after {
+    background-color: white;
+    transform: rotate(-45deg);
+    top: 11px;
+    width: 13px;
+  }
+
+  [disabled] + label {
+    pointer-events: none;
+    border: none;
+    opacity: 0.6;
+    filter: grayscale(1);
+  }
+}

static/css/utils/inputs.scss

@@ -95,7 +95,6 @@ select {
 
   width: 100%;
   max-width: 600px;
-  -webkit-appearance: none;
   align-items: center;
   border: 1px solid transparent;
   border-radius: 4px;
@@ -162,6 +161,11 @@ textarea {
 }
 
 /* OPTIONS */
+
+select {
+  -webkit-appearance: menulist;
+}
+
 select,
 option {
   font-size: 1rem;
@@ -171,7 +175,8 @@ option {
   border-radius: 2px;
   outline: 0;
   color: #363636;
-  min-width: 200px;
+  min-width: 250px;
+  width: auto;
   background-color: #f3f3f3;
   box-shadow: inset 0 1px 2px 1px rgba(50,50,50,.05);
 }
@@ -183,130 +188,6 @@ option {
   }
 }
 
-/* CUSTOM LEGACY CHECKBOX AND RADIO BOXES */
-input[type="checkbox"] {
-  position: relative;
-  height: 20px;
-  width: 20px;
-  -webkit-appearance: none;
-  appearance: none;
-  cursor: pointer;
-}
-input[type="checkbox"]::before {
-  content: '';
-  position: absolute;
-  width: 20px;
-  height: 20px;
-  background-color: var(--color-lighter);
-  display: flex;
-  align-items: center;
-  justify-content: center;
-  border-radius: 2px;
-}
-input[type="checkbox"]:checked::before {
-  background-color: var(--color-light);
-}
-input[type="checkbox"]:checked::after {
-  content: '✓';
-  position: absolute;
-  width: 20px;
-  height: 20px;
-  display: flex;
-  align-items: center;
-  justify-content: center;
-  color: white;
-  font-size: 20px;
-}
-
-/* CUSTOM CHECKBOXES AND RADIO BOXES */
-/* Completely replaces legacy checkbox and radiobox */
-.checkbox,
-.radio {
-  position: relative;
-  display: inline-block;
-
-  [type="checkbox"],
-  [type="radio"] {
-    position: fixed;
-    top: -1px;
-    left: -1px;
-    width: 1px;
-    height: 1px;
-    overflow: hidden;
-  }
-
-  label {
-    display: block;
-    height: 24px;
-    width: 24px;
-    background-color: #f3f3f3;
-    box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05);
-    border: 2px solid var(--color-primary);
-    border-radius: 4px;
-    color: white;
-    cursor: pointer;
-  }
-
-  label::before,
-  label::after {
-    position: absolute;
-    display: block;
-    top: 12px;
-    left: 8px;
-    height: 2px;
-    width: 8px;
-    background-color: var(--color-font);
-  }
-
-  :checked + label {
-    background-color: var(--color-primary);
-  }
-
-  [type="checkbox"]:focus + label,
-  [type="radio"]:focus + label {
-    border-color: #3273dc;
-    box-shadow: 0 0 0 0.125em rgba(50,115,220,.25);
-    outline: 0;
-  }
-
-  :checked + label::before,
-  :checked + label::after {
-    content: '';
-  }
-
-  :checked + label::before {
-    background-color: white;
-    transform: rotate(45deg);
-    left: 4px;
-  }
-
-  :checked + label::after {
-    background-color: white;
-    transform: rotate(-45deg);
-    top: 11px;
-    width: 13px;
-  }
-
-  [disabled] + label {
-    pointer-events: none;
-    border: none;
-    opacity: 0.6;
-    filter: grayscale(1);
-  }
-}
-
-.radio::before {
-  content: '';
-  position: absolute;
-  top: 2px;
-  left: 2px;
-  right: 2px;
-  bottom: 2px;
-  border-radius: 4px;
-  border: 2px solid white;
-  z-index: -1;
-}
-
 /* CUSTOM FILE INPUT */
 .file-input__label {
   cursor: pointer;

static/css/utils/modal.scss

@@ -3,7 +3,7 @@
   left: 50%;
   top: 50%;
   transform: translate(-50%, -50%) scale(0.8, 0.8);
-  display: block;
+  display: flex;
   background-color: rgba(255, 255, 255, 1);
   min-width: 60vw;
   min-height: 100px;
@@ -26,10 +26,6 @@
     z-index: 200;
     transform: translate(-50%, -50%) scale(1, 1);
   }
-
-  .modal__content {
-    margin: 20px 0;
-  }
 }
 
 @media (max-width: 1024px) {
@@ -96,3 +92,8 @@
     color: white;
   }
 }
+
+.modal__content {
+  margin: 20px 0;
+  width: 100%;
+}

static/css/utils/radio.scss

@@ -0,0 +1,76 @@
+/* CUSTOM RADIO BOXES */
+/* Completely replaces native radiobox */
+
+.radio-group {
+  display: flex;
+}
+
+.radio-group__option {
+  min-width: 30px;
+}
+
+.radio {
+  position: relative;
+  display: inline-block;
+
+  [type="radio"] {
+    position: fixed;
+    top: -1px;
+    left: -1px;
+    width: 1px;
+    height: 1px;
+    overflow: hidden;
+  }
+
+  label {
+    display: block;
+    height: 34px;
+    min-width: 42px;
+    line-height: 34px;
+    text-align: center;
+    padding: 0 13px;
+    background-color: #f3f3f3;
+    box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05);
+    color: var(--color-font);
+    cursor: pointer;
+  }
+
+  :checked + label {
+    background-color: var(--color-primary);
+    color: var(--color-lightwhite);
+    box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15);
+  }
+
+  :focus + label {
+    border-color: #3273dc;
+    box-shadow: 0 0 0.125em 0 rgba(50,115,220,0.8);
+    outline: 0;
+  }
+
+  [disabled] + label {
+    pointer-events: none;
+    border: none;
+    opacity: 0.6;
+    filter: grayscale(1);
+  }
+}
+
+.radio:first-child {
+  label {
+    border-top-left-radius: 4px;
+    border-bottom-left-radius: 4px;
+  }
+}
+
+.radio:last-child {
+  label {
+    border-top-right-radius: 4px;
+    border-bottom-right-radius: 4px;
+  }
+}
+
+@media (max-width: 768px) {
+  .radio + .radio {
+    margin-left: 10px;
+  }
+}

static/css/utils/showHide.scss

@@ -1,22 +1,30 @@
+$show-hide-toggle-size: 6px;
+
 .js-show-hide__toggle {
+
   position: relative;
   cursor: pointer;
+  padding: 3px 7px;
+
+  &:hover {
+    background-color: var(--color-grey-lighter);
+    cursor: pointer;
+  }
 }
 
 .js-show-hide__toggle::before {
   content: '';
   position: absolute;
-  width: 0;
+  width: $show-hide-toggle-size;
-  height: 0;
+  height: $show-hide-toggle-size;
-  left: -28px;
+  left: -15px;
-  top: 6px;
+  top: 12px - $show-hide-toggle-size / 2;
   color: var(--color-primary);
-  border-right: 8px solid transparent;
+  border-right: 2px solid currentColor;
-  border-top: 8px solid transparent;
+  border-top: 2px solid currentColor;
-  border-left: 8px solid transparent;
-  border-bottom: 8px solid currentColor;
   transition: transform .2s ease;
-  transform-origin: 8px 12px;
+  transform-origin: ($show-hide-toggle-size / 2);
+  transform: translateY($show-hide-toggle-size) rotate(-45deg);
 }
 
 .js-show-hide__target {
@@ -26,7 +34,7 @@
 .js-show-hide--collapsed {
 
   .js-show-hide__toggle::before {
-    transform: rotate(180deg);
+    transform: translateY($show-hide-toggle-size / 3) rotate(135deg);
   }
 
   .js-show-hide__target {

static/js/utils/alerts.js

@@ -87,5 +87,10 @@
 
     initToggler();
     alertElements.forEach(initAlert);
+
+    return {
+      scope: alertsEl,
+      destroy: function() {},
+    };
   };
 })();

static/js/utils/asidenav.js

@@ -55,5 +55,10 @@
 
     initFavoritesButton();
     initAsidenavSubmenus();
+
+    return {
+      scope: asideEl,
+      destroy: function() {},
+    };
   };
 })();

static/js/utils/asyncForm.js

@@ -6,9 +6,12 @@
   var ASYNC_FORM_RESPONSE_CLASS = 'async-form-response';
   var ASYNC_FORM_LOADING_CLASS = 'async-form-loading';
   var ASYNC_FORM_MIN_DELAY = 600;
+  var DEFAULT_FAILURE_MESSAGE = 'The response we received from the server did not match what we expected. Please let us know this happened via the help widget in the top navigation.';
 
   window.utils.asyncForm = function(formElement, options) {
 
+    options = options || {};
+
     var lastRequestTimestamp = 0;
 
     function setup() {
@@ -16,19 +19,27 @@
     }
 
     function processResponse(response) {
-      var responseElement = document.createElement('div');
+      var responseElement = makeResponseElement(response.content, response.status);
-      responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS);
-      responseElement.innerHTML = response.content;
       var parentElement = formElement.parentElement;
 
       // make sure there is a delay between click and response
       var delay = Math.max(0, ASYNC_FORM_MIN_DELAY + lastRequestTimestamp - Date.now());
+
       setTimeout(function() {
         parentElement.insertBefore(responseElement, formElement);
         formElement.remove();
       }, delay);
     }
 
+    function makeResponseElement(content, status) {
+      var responseElement = document.createElement('div');
+      status = status || 'info';
+      responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS);
+      responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS + '--' + status);
+      responseElement.innerHTML = content;
+      return responseElement;
+    }
+
     function submitHandler(event) {
       event.preventDefault();
 
@@ -47,14 +58,29 @@
 
       window.utils.httpClient.post(url, headers, body)
         .then(function(response) {
-          return response.json();
+          if (response.headers.get("content-type").indexOf("application/json") !== -1) {// checking response header
+            return response.json();
+          } else {
+            throw new TypeError('Unexpected Content-Type. Expected Content-Type: "application/json". Requested URL:' + url + '"');
+          }
         }).then(function(response) {
-          processResponse(response[0])
+          processResponse(response[0]);
         }).catch(function(error) {
-          console.error('could not fetch or process response from ' + url, { error });
+          var failureMessage = DEFAULT_FAILURE_MESSAGE;
+          if (options.i18n && options.i18n.asyncFormFailure) {
+            failureMessage = options.i18n.asyncFormFailure;
+          }
+          processResponse({ content: failureMessage });
+
+          formElement.classList.remove(ASYNC_FORM_LOADING_CLASS);
         });
     }
 
     setup();
+
+    return {
+      scope: formElement,
+      destroy: function() {},
+    };
   };
 })();

static/js/utils/asyncTable.js

@@ -5,6 +5,10 @@
 
   var HEADER_HEIGHT = 80;
   var RESET_OPTIONS = [ 'scrollTo' ];
+  var TABLE_FILTER_FORM_CLASS = 'table-filter-form';
+  var ASYNC_TABLE_CONTENT_CHANGED_CLASS = 'async-table--changed';
+  var ASYNC_TABLE_LOADING_CLASS = 'async-table--loading';
+  var JS_INITIALIZED_CLASS = 'js-async-table-initialized';
 
   window.utils.asyncTable = function(wrapper, options) {
 
@@ -17,6 +21,8 @@
     var pagesizeForm;
     var scrollTable;
 
+    var utilInstances = [];
+
     function init() {
       var table = wrapper.querySelector('#' + tableIdent);
 
@@ -42,17 +48,30 @@
       // pagesize form
       pagesizeForm = wrapper.querySelector('#' + tableIdent + '-pagesize-form');
 
+      // check all
+      utilInstances.push(window.utils.setup('checkAll', wrapper));
+
+      // showhide
+      utilInstances.push(window.utils.setup('showHide', wrapper));
+
+      // filter
+      var filterForm = wrapper.querySelector('.' + TABLE_FILTER_FORM_CLASS);
+      if (filterForm) {
+        options.updateTableFrom = updateTableFrom;
+        utilInstances.push(window.utils.setup('asyncTableFilter', filterForm, options));
+      }
+
       // take options into account
-      if (options && options.scrollTo) {
+      if (options.scrollTo) {
         window.scrollTo(options.scrollTo);
       }
 
-      if (options && options.horizPos && scrollTable) {
+      if (options.horizPos && scrollTable) {
         scrollTable.scrollLeft = options.horizPos;
       }
 
       setupListeners();
-      wrapper.classList.add('js-initialized');
+      wrapper.classList.add(JS_INITIALIZED_CLASS);
     }
 
     function setupListeners() {
@@ -117,32 +136,22 @@
     }
 
     function changePagesizeHandler(event) {
-      var currentTableUrl = options.currentUrl || window.location.href;
+      var pagesizeParamKey = tableIdent + '-pagesize';
-      var url = getUrlWithUpdatedPagesize(currentTableUrl, event.target.value);
+      var pageParamKey = tableIdent + '-page';
-      url = new URL(getUrlWithResetPagenumber(url));
+      var url = new URL(options.currentUrl || window.location.href);
+      url.searchParams.set(pagesizeParamKey, event.target.value);
+      url.searchParams.set(pageParamKey, 0);
       updateTableFrom(url);
     }
 
-    function getUrlWithUpdatedPagesize(url, pagesize) {
-      if (url.indexOf('pagesize') >= 0) {
-        return url.replace(/pagesize=(\d+|all)/, 'pagesize=' + pagesize);
-      } else if (url.indexOf('?') >= 0) {
-        return url += '&' + tableIdent + '-pagesize=' + pagesize;
-      }
-
-      return url += '?' + tableIdent + '-pagesize=' + pagesize;
-    }
-
-    function getUrlWithResetPagenumber(url) {
-      return url.replace(/-page=\d+/, '-page=0');
-    }
-
     // fetches new sorted table from url with params and replaces contents of current table
-    function updateTableFrom(url, tableOptions) {
+    function updateTableFrom(url, tableOptions, callback) {
       if (!window.utils.httpClient) {
         throw new Error('httpClient not found!');
       }
 
+      wrapper.classList.add(ASYNC_TABLE_LOADING_CLASS);
+
       tableOptions = tableOptions || {};
       var headers = {
         'Accept': 'text/html',
@@ -157,6 +166,11 @@
         tableOptions.currentUrl = url.href;
         removeListeners();
         updateWrapperContents(data, tableOptions);
+        if (callback && typeof callback === 'function') {
+          callback(wrapper);
+        }
+
+        wrapper.classList.remove(ASYNC_TABLE_LOADING_CLASS);
       }).catch(function(err) {
         console.error(err);
       });
@@ -165,11 +179,11 @@
     function updateWrapperContents(newHtml, tableOptions) {
       tableOptions = tableOptions || {};
       wrapper.innerHTML = newHtml;
-      wrapper.classList.remove("js-initialized");
+      wrapper.classList.remove(JS_INITIALIZED_CLASS);
+      wrapper.classList.add(ASYNC_TABLE_CONTENT_CHANGED_CLASS);
+
+      destroyUtils();
 
-      // setup the wrapper and its components to behave async again
-      window.utils.teardown('asyncTable');
-      window.utils.teardown('form');
       // merge global options and table specific options
       var resetOptions = {};
       Object.keys(options)
@@ -195,13 +209,26 @@
       window.utils.setup('asyncTable', wrapper, combinedOptions);
 
       Array.from(wrapper.querySelectorAll('form')).forEach(function(form) {
-        window.utils.setup('form', form);
+        utilInstances.push(window.utils.setup('form', form));
       });
       Array.from(wrapper.querySelectorAll('.modal')).forEach(function(modal) {
-        window.utils.setup('modal', modal);
+        utilInstances.push(window.utils.setup('modal', modal));
+      });
+    }
+
+    function destroyUtils() {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
+        utilInstance.destroy();
       });
     }
 
     init();
+
+    return {
+      scope: wrapper,
+      destroy: destroyUtils,
+    };
   };
 })();

static/js/utils/asyncTableFilter.js

@@ -0,0 +1,166 @@
+(function () {
+  'use strict';
+
+  window.utils = window.utils || {};
+
+  var ASYNC_TABLE_FILTER_LOADING_CLASS = 'async-table-filter--loading';
+  var JS_INITIALIZED_CLASS = 'js-async-table-filter-initialized';
+  var INPUT_DEBOUNCE = 600;
+
+  // debounce function, taken from Underscore.js
+  function debounce(func, wait, immediate) {
+    var timeout;
+    return function() {
+      var context = this, args = arguments;
+      var later = function() {
+        timeout = null;
+        if (!immediate) func.apply(context, args);
+      };
+      var callNow = immediate && !timeout;
+      clearTimeout(timeout);
+      timeout = setTimeout(later, wait);
+      if (callNow) func.apply(context, args);
+    };
+  };
+
+  window.utils.asyncTableFilter = function(formElement, options) {
+    if (!options || !options.updateTableFrom) {
+      return false;
+    }
+
+    if (formElement.matches('.' + JS_INITIALIZED_CLASS)) {
+      return false;
+    }
+    options = options || {};
+    var tableIdent = options.dbtIdent;
+
+    var formId = formElement.querySelector('[name="_formid"]').value;
+    var inputs = {
+      search: [],
+      input: [],
+      change: [],
+      select: [],
+    }
+
+    function setup() {
+      gatherInputs();
+      addEventListeners();
+    }
+
+    function gatherInputs() {
+      Array.from(formElement.querySelectorAll('input[type="search"]')).forEach(function(input) {
+        inputs.search.push(input);
+      });
+
+      Array.from(formElement.querySelectorAll('input[type="text"]')).forEach(function(input) {
+        inputs.input.push(input);
+      });
+
+      Array.from(formElement.querySelectorAll('input:not([type="text"]):not([type="search"])')).forEach(function(input) {
+        inputs.change.push(input);
+      });
+
+      Array.from(formElement.querySelectorAll('select')).forEach(function(input) {
+        inputs.select.push(input);
+      });
+    }
+
+    function addEventListeners() {
+      inputs.search.forEach(function(input) {
+        var debouncedInput = debounce(function() {
+          if (input.value.length === 0 || input.value.length > 2) {
+            updateTable();
+          }
+        }, INPUT_DEBOUNCE);
+        input.addEventListener('input', debouncedInput);
+      });
+
+      inputs.input.forEach(function(input) {
+        var debouncedInput = debounce(function() {
+          if (input.value.length === 0 || input.value.length > 2) {
+            updateTable();
+          }
+        }, INPUT_DEBOUNCE);
+        input.addEventListener('input', debouncedInput);
+      });
+
+      inputs.change.forEach(function(input) {
+        input.addEventListener('change', function() {
+          updateTable();
+        });
+      });
+
+      inputs.select.forEach(function(input) {
+        input.addEventListener('change', function() {
+          updateTable();
+        });
+      });
+
+      formElement.addEventListener('submit', function(event) {
+        event.preventDefault();
+        updateTable();
+      });
+    }
+
+    function updateTable() {
+      var url = serializeFormToURL();
+      var callback = null;
+
+      formElement.classList.add(ASYNC_TABLE_FILTER_LOADING_CLASS);
+
+      var focusedSearch = inputs.search.reduce(function(acc, input) {
+        return acc || (input.matches(':focus') && input);
+      }, null);
+      // focus search input
+      if (focusedSearch) {
+        var selectionStart = focusedSearch.selectionStart;
+        callback = function(wrapper) {
+          var search = wrapper.querySelector('input[type="search"]');
+          if (search) {
+            search.focus();
+            search.selectionStart = selectionStart;
+          }
+        };
+      }
+      options.updateTableFrom(url, options, callback);
+    }
+
+    function serializeFormToURL() {
+      var url = new URL(options.currentUrl || window.location.href);
+      url.searchParams.set('_formid', formId);
+      url.searchParams.set('_hasdata', 'true');
+      url.searchParams.set(tableIdent + '-page', '0');
+
+      inputs.search.forEach(function(input) {
+        url.searchParams.set(input.name, input.value);
+      });
+
+      inputs.input.forEach(function(input) {
+        url.searchParams.set(input.name, input.value);
+      });
+
+      inputs.change.forEach(function(input) {
+        if (input.checked) {
+          url.searchParams.set(input.name, input.value);
+        }
+      });
+
+      inputs.select.forEach(function(select) {
+        var options = Array.from(select.querySelectorAll('option'));
+        var selected = options.find(function(option) { return option.selected });
+        if (selected) {
+          url.searchParams.set(select.name, selected.value);
+        }
+      });
+
+      return url;
+    }
+
+    setup();
+
+    return {
+      scope: formElement,
+      destroy: function() {},
+    };
+  }
+})();

static/js/utils/checkAll.js

@@ -3,6 +3,7 @@
 
   window.utils = window.utils || {};
 
+  var ASYNC_TABLE_CONTENT_CHANGED_CLASS = 'async-table--changed';
   var JS_INITIALIZED_CLASS = 'js-check-all-initialized';
   var CHECKBOX_SELECTOR    = '[type="checkbox"]';
 
@@ -12,7 +13,7 @@
 
   window.utils.checkAll = function(wrapper, options) {
 
-    if (!wrapper || wrapper.classList.contains(JS_INITIALIZED_CLASS)) {
+    if ((!wrapper || wrapper.classList.contains(JS_INITIALIZED_CLASS)) && !wrapper.classList.contains(ASYNC_TABLE_CONTENT_CHANGED_CLASS)) {
       return false;
     }
     options = options || {};
@@ -21,6 +22,8 @@
     var checkboxColumn = [];
     var checkAllCheckbox = null;
 
+    var utilInstances = [];
+
     function init() {
 
       columns = gatherColumns(wrapper);
@@ -79,7 +82,7 @@
       checkAllCheckbox.setAttribute('id', getCheckboxId());
       th.innerHTML = '';
       th.insertBefore(checkAllCheckbox, null);
-      window.utils.setup('checkboxRadio', checkAllCheckbox);
+      utilInstances.push(window.utils.setup('checkbox', checkAllCheckbox));
 
       checkAllCheckbox.addEventListener('input', onCheckAllCheckboxInput);
       setupCheckboxListeners();
@@ -112,6 +115,17 @@
       });
     }
 
+    function destroy() {
+      utilInstances.forEach(function(util) {
+        util.destroy();
+      });
+    }
+
     init();
+
+    return {
+      scope: wrapper,
+      destroy: destroy,
+    };
   };
 })();

static/js/utils/form.js

@@ -25,36 +25,50 @@
       return false;
     }
 
+    var utilInstances = [];
+
     // reactive buttons
-    var submitBtn = form.querySelector(SUBMIT_BUTTON_SELECTOR);
+    utilInstances.push(window.utils.setup('reactiveButton', form));
-    if (submitBtn) {
-      window.utils.setup('reactiveButton', form, { button: submitBtn });
-    }
 
     // conditonal fieldsets
     var fieldSets = Array.from(form.querySelectorAll('fieldset[data-conditional-id][data-conditional-value]'));
-    window.utils.setup('interactiveFieldset', form, { fieldSets });
+    utilInstances.push(window.utils.setup('interactiveFieldset', form, { fieldSets }));
 
     // hide autoSubmit submit button
-    window.utils.setup('autoSubmit', form, options);
+    utilInstances.push(window.utils.setup('autoSubmit', form, options));
 
     // async form
     if (AJAX_SUBMIT_FLAG in form.dataset) {
-      window.utils.setup('asyncForm', form, options);
+      utilInstances.push(window.utils.setup('asyncForm', form, options));
     }
 
+    // inputs
+    utilInstances.push(window.utils.setup('inputs', form, options));
+
     form.classList.add(JS_INITIALIZED);
+
+    function destroyUtils() {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
+        utilInstance.destroy();
+      });
+    }
+
+    return {
+      scope: form,
+      destroy: destroyUtils,
+    };
   };
 
   // registers input-listener for each element in <inputs> (array) and
   // enables <button> if <formValidator> for these inputs returns true
   window.utils.reactiveButton = function(form, options) {
-    options = options || {};
+    var button = form.querySelector(SUBMIT_BUTTON_SELECTOR);
-    var button = options.button;
     var requireds = Array.from(form.querySelectorAll('[required]'));
 
-    if (!button) {
+    if (!button || button.matches(AUTOSUBMIT_BUTTON_SELECTOR)) {
-      throw new Error('Please provide both a button to reactiveButton');
+      return false;
     }
 
     if (requireds.length == 0) {
@@ -84,6 +98,11 @@
         button.setAttribute('disabled', 'true');
       }
     }
+
+    return {
+      scope: form,
+      destroy: function() {},
+    };
   };
 
   window.utils.interactiveFieldset = function(form, options) {
@@ -121,6 +140,11 @@
       addEventListeners();
       updateFields();
     }
+
+    return {
+      scope: form,
+      destroy: function() {},
+    };
   };
 
   window.utils.autoSubmit = function(form, options) {
@@ -128,5 +152,10 @@
     if (button) {
       button.classList.add('hidden');
     }
+
+    return {
+      scope: form,
+      destroy: function() {},
+    };
   };
 })();

static/js/utils/inputs.js

@@ -10,22 +10,45 @@
   }
 
   window.utils.inputs = function(wrapper, options) {
-    // checkboxes / radios
+
-    var checkboxes = Array.from(wrapper.querySelectorAll('input[type="checkbox"], input[type="radio"]'));
+    var utilInstances = [];
-    checkboxes.filter(isNotInitialized).forEach(window.utils.checkboxRadio);
+
+    // checkboxes
+    var checkboxes = Array.from(wrapper.querySelectorAll('input[type="checkbox"]'));
+    checkboxes.filter(isNotInitialized).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) {
+      utilInstances.push(window.utils.setup('radio', radio));
+    });
 
     // file-uploads
     var fileUploads = Array.from(wrapper.querySelectorAll('input[type="file"]'));
     fileUploads.filter(isNotInitialized).forEach(function(input) {
-      window.utils.fileUpload(input, options);
+      utilInstances.push(window.utils.setup('fileUpload', input, options));
     });
 
     // file-checkboxes
     var fileCheckboxes = Array.from(wrapper.querySelectorAll('.file-checkbox'));
-    fileCheckboxes.filter(isNotInitialized).forEach(function(inp) {
+    fileCheckboxes.filter(isNotInitialized).forEach(function(input) {
-      window.utils.fileCheckbox(inp);
+      utilInstances.push(window.utils.setup('fileCheckbox', input, options));
-      inp.classList.add(JS_INITIALIZED_CLASS);
     });
+
+    function destroyUtils() {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
+        utilInstance.destroy();
+      });
+    }
+
+    return {
+      scope: wrapper,
+      destroy: destroyUtils,
+    };
   };
 
   // (multiple) dynamic file uploads
@@ -113,6 +136,11 @@
 
       updateLabel(input.files);
     });
+
+    return {
+      scope: input,
+      destroy: function() {},
+    };
   }
 
   // to remove previously uploaded files
@@ -141,20 +169,24 @@
       input.classList.add(JS_INITIALIZED_CLASS);
       cont.classList.add(JS_INITIALIZED_CLASS);
     }
+
     setup();
+
+    return {
+      scope: input,
+      destroy: function() {},
+    };
   }
 
-  // turns native checkboxes and radio buttons into custom ones
+  // turns native checkboxes into custom ones
-  window.utils.checkboxRadio = function(input) {
+  window.utils.checkbox = function(input) {
 
-    var type = input.getAttribute('type');
+    if (!input.parentElement.classList.contains('checkbox')) {
-
-    if (!input.parentElement.classList.contains(type)) {
       var parentEl = input.parentElement;
       var siblingEl = input.nextElementSibling;
       var wrapperEl = document.createElement('div');
       var labelEl = document.createElement('label');
-      wrapperEl.classList.add(type);
+      wrapperEl.classList.add('checkbox');
       labelEl.setAttribute('for', input.id);
       wrapperEl.appendChild(input);
       wrapperEl.appendChild(labelEl);
@@ -166,6 +198,35 @@
         parentEl.appendChild(wrapperEl);
       }
     }
+
+    return {
+      scope: input,
+      destroy: function() {},
+    };
+  }
+
+  // turns native radio buttons into custom ones
+  window.utils.radio = function(input) {
+
+    if (!input.parentElement.classList.contains('radio')) {
+      var parentEl = input.parentElement;
+      var siblingEl = input.nextElementSibling;
+      var wrapperEl = document.createElement('div');
+      wrapperEl.classList.add('radio');
+      wrapperEl.appendChild(input);
+
+      if (siblingEl && siblingEl.matches('label')) {
+        wrapperEl.appendChild(siblingEl);
+      }
+
+      input.classList.add(JS_INITIALIZED_CLASS);
+      parentEl.appendChild(wrapperEl);
+    }
+
+    return {
+      scope: input,
+      destroy: function() {},
+    };
   }
 
 })();

static/js/utils/modal.js

@@ -23,6 +23,8 @@
       return;
     }
 
+    var utilInstances = [];
+
     var overlayElement = document.createElement('div');
     var closerElement = document.createElement('div');
     var triggerElement = document.querySelector('#' + modalElement.dataset.trigger);
@@ -73,7 +75,7 @@
     function setupForm() {
       var form = modalElement.querySelector('form');
       if (form) {
-        window.utils.setup('form', form, { headers: MODAL_HEADERS });
+        utilInstances.push(window.utils.setup('form', form, { headers: MODAL_HEADERS }));
       }
     }
 
@@ -112,10 +114,23 @@
       if (previousModalContent) {
         previousModalContent.remove();
       }
+
+      modalContent = withPrefixedInputIDs(modalContent);
       modalElement.insertBefore(modalContent, null);
       setupForm();
     }
 
+    function withPrefixedInputIDs(modalContent) {
+      var idAttrs = ['id', 'for', 'data-conditional-id'];
+      idAttrs.forEach(function(attr) {
+        modalContent.querySelectorAll('[' + attr + ']').forEach(function(input) {
+          var value = modalElement.id + '__' + input.getAttribute(attr);
+          input.setAttribute(attr, value);
+        });
+      });
+      return modalContent;
+    }
+
     function keyupHandler(event) {
       if (event.key === 'Escape') {
         close();
@@ -123,5 +138,18 @@
     }
 
     setup();
+
+    function destroyUtils() {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
+        utilInstance.destroy();
+      });
+    }
+
+    return {
+      scope: modalElement,
+      destroy: destroyUtils,
+    };
   };
 })();

static/js/utils/setup.js

@@ -4,6 +4,7 @@
   window.utils = window.utils || {};
 
   var registeredSetupListeners = {};
+  var activeInstances = {};
 
 /**
  * setup function to initiate a util (utilName) on a scope (sope) with options (options).
@@ -13,53 +14,98 @@
  */
 
   window.utils.setup = function(utilName, scope, options) {
-
     if (!utilName || !scope) {
       return;
     }
 
     options = options || {};
 
-    var listener = function(event) {
+    var utilInstance;
 
-      if (event.detail.targetUtil !== utilName) {
+    // i18n
-        return false;
+    if (window.I18N) {
-      }
+      options.i18n = window.I18N;
-
-      if (options.setupFunction) {
-        options.setupFunction(scope, options);
-      } else {
-        var util = window.utils[utilName];
-        if (!util) {
-          throw new Error('"' + utilName + '" is not a known js util');
-        }
-
-        util(scope, options);
-      }
-    };
-
-    if (registeredSetupListeners[utilName] && !options.singleton) {
-      registeredSetupListeners[utilName].push(listener);
-    } else {
-      window.utils.teardown(utilName);
-      registeredSetupListeners[utilName] = [ listener ];
     }
 
-    document.addEventListener('setup', listener);
+    if (activeInstances[utilName]) {
+      var instanceWithSameScope = activeInstances[utilName]
+        .filter(function(instance) { return !!instance; })
+        .find(function(instance) {
+          return instance.scope === scope;
+        });
+      var isAlreadySetup = !!instanceWithSameScope;
 
-    document.dispatchEvent(new CustomEvent('setup', {
+      if (isAlreadySetup) {
-      detail: { targetUtil: utilName, module: 'none' },
+        console.warn('Trying to setup a JS utility that\'s already been set up', { utility: utilName, scope, options });
-      bubbles: true,
+      }
-      cancelable: true,
+    }
-    }));
+
+    function setup() {
+      var listener = function(event) {
+        if (event.detail.targetUtil !== utilName) {
+          return false;
+        }
+
+        if (options.setupFunction) {
+          utilInstance = options.setupFunction(scope, options);
+        } else {
+          var util = window.utils[utilName];
+          if (!util) {
+            throw new Error('"' + utilName + '" is not a known js util');
+          }
+
+          utilInstance = util(scope, options);
+        }
+
+        if (utilInstance) {
+          if (activeInstances[utilName] && Array.isArray(activeInstances[utilName])) {
+            activeInstances[utilName].push(utilInstance);
+          } else {
+            activeInstances[utilName] = [ utilInstance ];
+          }
+        }
+      };
+
+      if (registeredSetupListeners[utilName] && Array.isArray(registeredSetupListeners[utilName])) {
+        window.utils.teardown(utilName);
+      }
+
+      if (!registeredSetupListeners[utilName] || Array.isArray(registeredSetupListeners[utilName])) {
+        registeredSetupListeners[utilName] = [];
+      }
+      registeredSetupListeners[utilName].push(listener);
+
+      document.addEventListener('setup', listener);
+
+      document.dispatchEvent(new CustomEvent('setup', {
+        detail: { targetUtil: utilName, module: 'none' },
+        bubbles: true,
+        cancelable: true,
+      }));
+    }
+
+    setup();
+
+    return utilInstance;
   };
 
-  window.utils.teardown = function(utilName) {
+  window.utils.teardown = function(utilName, destroy) {
     if (registeredSetupListeners[utilName]) {
-      registeredSetupListeners[utilName].forEach(function(listener) {
+      registeredSetupListeners[utilName]
-        document.removeEventListener('setup', listener);
+        .filter(function(listener) { return !!listener })
-      });
+        .forEach(function(listener) {
+          document.removeEventListener('setup', listener);
+        });
       delete registeredSetupListeners[utilName];
     }
+
+    if (destroy === true && activeInstances[utilName]) {
+      activeInstances[utilName]
+        .filter(function(instance) { return !!instance })
+        .forEach(function(instance) {
+          instance.destroy();
+        });
+      delete activeInstances[utilName];
+    }
   }
 })();

static/js/utils/showHide.js

@@ -3,7 +3,12 @@
 
   window.utils = window.utils || {};
 
+  var JS_INITIALIZED_CLASS = 'js-show-hide-initialized';
   var LOCAL_STORAGE_SHOW_HIDE = 'SHOW_HIDE';
+  var SHOW_HIDE_TOGGLE_CLASS = 'js-show-hide__toggle';
+  var SHOW_HIDE_COLLAPSED_CLASS = 'js-show-hide--collapsed';
+  var SHOW_HIDE_TARGET_CLASS = 'js-show-hide__target';
+
   /**
    * div
    *   div.js-show-hide__toggle
@@ -12,9 +17,12 @@
    *     content here
    */
   window.utils.showHide = function(wrapper, options) {
+
+    options = options || {};
+
     function addEventHandler(el) {
       el.addEventListener('click', function elClickListener() {
-        var newState = el.parentElement.classList.toggle('js-show-hide--collapsed');
+        var newState = el.parentElement.classList.toggle(SHOW_HIDE_COLLAPSED_CLASS);
         updateLSState(el.dataset.shIndex || null, newState);
       });
     }
@@ -23,33 +31,47 @@
       if (!index) {
         return false;
       }
-      var lsData = fromLocalStorage();
+      var lsData = getLocalStorageData();
       lsData[index] = state;
       window.localStorage.setItem(LOCAL_STORAGE_SHOW_HIDE, JSON.stringify(lsData));
     }
 
     function collapsedStateInLocalStorage(index) {
-      return fromLocalStorage()[index] || null;
+      var lsState = getLocalStorageData();
+      return lsState[index];
     }
 
-    function fromLocalStorage() {
+    function getLocalStorageData() {
       return JSON.parse(window.localStorage.getItem(LOCAL_STORAGE_SHOW_HIDE)) || {};
     }
 
     Array
-      .from(wrapper.querySelectorAll('.js-show-hide__toggle'))
+      .from(wrapper.querySelectorAll('.' + SHOW_HIDE_TOGGLE_CLASS))
       .forEach(function(el) {
+        if (el.classList.contains(JS_INITIALIZED_CLASS)) {
+          return false;
+        }
+
         var index = el.dataset.shIndex || null;
-        el.parentElement.classList.toggle(
+        var isCollapsed = el.dataset.collapsed === 'true';
-          'js-show-hide--collapsed',
+        var lsCollapsedState = collapsedStateInLocalStorage(index);
-          collapsedStateInLocalStorage(index) || el.dataset.collapsed === 'true'
+        if (typeof lsCollapsedState !== 'undefined') {
-        );
+          isCollapsed = lsCollapsedState;
+        }
+        el.parentElement.classList.toggle(SHOW_HIDE_COLLAPSED_CLASS, isCollapsed);
+
         Array.from(el.parentElement.children).forEach(function(el) {
-          if (!el.classList.contains('js-show-hide__toggle')) {
+          if (!el.classList.contains('' + SHOW_HIDE_TOGGLE_CLASS)) {
-            el.classList.add('js-show-hide__target');
+            el.classList.add(SHOW_HIDE_TARGET_CLASS);
           }
         });
+        el.classList.add(JS_INITIALIZED_CLASS);
         addEventHandler(el);
     });
+
+    return {
+      scope: wrapper,
+      destroy: function() {},
+    };
   };
 })();

templates/adminFeatures.hamlet

@@ -0,0 +1,19 @@
+<section>
+  ^{degreeTable}
+<section>
+  ^{studytermsTable}
+<section>
+    <h2>_{MsgStudyFeatureInference}
+    <p>
+      $if null infConflicts
+        Kein Konflikte beobachtet.
+      $else
+        <h3>Studiengangseingträge mit beobachteten Konflikten:
+        <ul>
+          $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
+            <li> #{show ky} - #{foldMap id nm}
+    <form .form-inline method=post action=@{AdminFeaturesR} enctype=#{btnEnctype}>
+      ^{btnWdgt}
+
+    <div .container>
+      ^{candidateTable}

templates/adminUser.hamlet

@@ -1,5 +1,6 @@
 <p>
-  <a href="mailto:#{userEmail}">#{userEmail}
+  $# Does not use link-email.hamlet, but should
+  ^{mailtoHtml userEmail}
 <form method=post action=@{AdminUserR uuid} enctype=#{formEnctype}>
   ^{formWidget}
   ^{submitButtonView}

templates/course.hamlet

@@ -18,7 +18,9 @@
         <dt .deflist__dt>_{MsgLecturerFor}
       <dd .deflist__dd>
         <div>
-          #{T.intercalate ", " lecturers}
+          <ul .list--inline .list--comma-separated>
+            $forall (E.Value displayname, E.Value surname, E.Value email) <- lecturers
+              <li>^{nameEmailWidget email displayname surname}
 
     $maybe link <- courseLinkExternal course
       <dt .deflist__dt>Website

templates/data-protection/de.hamlet

@@ -73,7 +73,7 @@
     <h4>Welche Daten werden erhoben
     Der Webserver protokolliert
     <ul>
-      <li>Pseudonymisierte IP-Adresse des Webclients des Nutzers dieses Dienstes
+      <li>IP-Adresse des Webclients des Nutzers dieses Dienstes
       <li>Datum und Uhrzeit des Abrufs eines Elementes der Webseite
       <li>Adresse des abgerufenen Elementes
       <li>übertragene Datenmenge

templates/default-layout.julius

@@ -35,14 +35,16 @@ function setupDatepicker(wrapper) {
   });
 }
 
-document.addEventListener('DOMContentLoaded', function() {
+// this global I18N object will be picked up automatically by the setup util
-  var I18N = {
+window.I18N = {
-    filesSelected: 'Dateien ausgewählt', // TODO: interpolate these to be translated
+  filesSelected: 'Dateien ausgewählt', // TODO: interpolate these to be translated
-    selectFile: 'Datei auswählen',
+  selectFile: 'Datei auswählen',
-    selectFiles: 'Datei(en) auswählen',
+  selectFiles: 'Datei(en) auswählen',
-  };
+  asyncFormFailure: 'Da ist etwas schief gelaufen, das tut uns Leid.<br>Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben.<br><br>Vielen Dank für deine Hilfe',
+};
 
+document.addEventListener('DOMContentLoaded', function() {
   window.utils.setup('flatpickr', document.body, { setupFunction: setupDatepicker });
   window.utils.setup('showHide', document.body);
-  window.utils.setup('inputs', document.body, { i18n: I18N });
+  window.utils.setup('inputs', document.body);
 });

templates/default-layout.lucius

@@ -8,6 +8,7 @@
   --color-lightwhite: #fcfffa;
   --color-grey: #B1B5C0;
   --color-grey-light: #efefef;
+  --color-grey-lighter: #f5f5f5;
   --color-grey-medium: #9A989E;
   --color-font: #34303a;
   --color-fontsec: #5b5861;

templates/dsgvDisclaimer.hamlet

@@ -10,5 +10,4 @@
       bitten um Ihr Verständnis.
     <p>
       Bitte melden Sie etwaige Probleme an #
-        <a href="mailto:jost@tcs.ifi.lmu.de">
+        ^{mailtoHtml "jost@tcs.ifi.lmu.de"}
-          jost@tcs.ifi.lmu.de

templates/imprint/de.hamlet

@@ -9,9 +9,7 @@ $newline never
       <li>Akademischer Rat
       <li>Oettingenstraße 67
       <li>D-80538 München
-      <li>E-Mail: #
+      <li>E-Mail: ^{mailtoHtml "jost@tcs.ifi.lmu.de"}
-        <a href="mailto:jost@tcs.ifi.lmu.de">
-          jost@tcs.ifi.lmu.de
       <li>Web: #
         <a href="https://www.tcs.ifi.lmu.de/mitarbeiter/steffen-jost">
           https://www.tcs.ifi.lmu.de/mitarbeiter/steffen-jost
@@ -24,9 +22,7 @@ $newline never
       <li>Leiter Rechnerbetriebsgruppe
       <li>Oettingenstraße 67
       <li>D-80538 München
-      <li>E-Mail: #
+      <li>E-Mail: ^{mailtoHtml "rbg@ifi.lmu.de"}
-        <a href="mailto:rbg@ifi.lmu.de">
-          rbg@ifi.lmu.de
       <li>Web: #
         <a href="https://www.rz.ifi.lmu.de/rbg/">
           https://www.rz.ifi.lmu.de/rbg/
@@ -41,7 +37,7 @@ $newline never
     <ul style="list-style-type: none">
       <li>Oettingenstraße 67
       <li>D-80538 München
-      <li>E-Mail: rbg@ifi.lmu.de
+      <li>E-Mail: ^{mailtoHtml "rbg@ifi.lmu.de"}
       <li>Web: https://www.rz.ifi.lmu.de/rbg/
       <li>Telefon: +49 (0) 89 / 2180 - 9198
     <p>
@@ -68,9 +64,7 @@ $newline never
       <li>Geschwister-Scholl-Platz 1
       <li>80539 München<
       <li>Telefon: +49 (0) 89 / 2180 - 0
-      <li>E-Mail: #
+      <li>E-Mail: ^{mailtoHtml "praesidium@lmu.de"}
-        <a href="mailto:praesidium@lmu.de">
-          praesidium@lmu.de
       <li>Web: #
         <a href="https://www.lmu.de/">
           https://www.lmu.de/

templates/info-lecturer/de.hamlet

@@ -135,9 +135,29 @@ hier die wichtigsten Neuerungen.
 
     <dt .deflist__dt> Papierabgaben
     <dd .deflist__dd>
-      Abgaben in anderer Form (z.B. Papierabgaben)
+      Externe Abgaben Form (z.B. Papierabgaben)
-      können mit Hilfe von Tokens verwaltet werden.
+      können mit Pseudonymen verwaltet werden:
-      Korrekturen können elektronisch zurückgegeben werden.
+      <ul>
+        <li>
+          Übungsblatt mit Abgabe-Modus
+          <i>Abgabe extern mit Pseudonym
+          anlegen
+        <li>
+          Studierende können sich auf
+          der Seite des Übungsblattes ein
+          Pseudonym generieren und ihre Abgabe
+          damit markieren.
+          <p>
+            Für jedes Übungsblatt müssen sich die
+            Studierenden ein neues Pseudonym
+            erstellen, damit eine anonyme Korrektur
+            gewährleistet werden kann.
+        <li>
+          Korrektoren bekommen die externen Abgaben
+          ausgehändigt.
+          Anhand der Pseudonyme werden
+          in Uni2work Abgaben angelegt,
+          welche wie üblich korrigiert werden können.
 
 <section>
   <h2>Klausuren

templates/profileData.hamlet

@@ -10,6 +10,12 @@
       <dd .deflist__dd> #{display userEmail}
       <dt .deflist__dt> _{MsgIdent}
       <dd .deflist__dd> #{display userIdent}
+      <dt .deflist__dt> _{MsgLastLogin}
+      <dd .deflist__dd>
+        $maybe llogin <- lastLogin 
+          #{llogin}
+        $nothing
+          _{MsgNever}
     $if not $ null admin_rights
       <dt .deflist__dt> Administrator
       <dd .deflist__dd>

templates/table/layout-filter-default.hamlet

@@ -1,8 +1,9 @@
 $newline never
-<section>
+<div .table-filter>
-  <form method=GET action=#{filterAction} enctype=#{filterEnctype}>
+  <h3 .js-show-hide__toggle data-sh-index=table-filter data-collapsed=true>Filter
-    ^{filterWgdt}
+  <div>
-    <button>
+    <form .table-filter-form method=GET action=#{filterAction} enctype=#{filterEnctype}>
-      ^{btnLabel BtnSubmit}
+      ^{filterWgdt}
-<section>
+      <button type=submit data-autosubmit>
-  ^{scrolltable}
+        ^{btnLabel BtnSubmit}
+^{scrolltable}

templates/table/layout-filter-default.lucius

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

templates/table/layout.julius

@@ -1,11 +1,10 @@
 document.addEventListener('DOMContentLoaded', function() {
-  var dbtIdent = #{String $ dbtIdent};
+  var dbtIdent = #{String dbtIdent};
   var headerDBTableShortcircuit = #{String (toPathPiece HeaderDBTableShortcircuit)};
   var selector = '#' + dbtIdent + '-table-wrapper';
   var wrapper = document.querySelector(selector);
 
   if (wrapper) {
     window.utils.setup('asyncTable', wrapper, { headerDBTableShortcircuit, dbtIdent });
-    window.utils.setup('checkAll', wrapper);
   }
 });

templates/widgets/fields/bool.hamlet

@@ -0,0 +1,14 @@
+$newline never
+<div .radio-group>
+  $if not isReq
+    <div .radio>
+      <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
+      <label for=#{theId}-none>_{MsgCourseFilterNone}
+
+  <div .radio>
+    <input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
+    <label for=#{theId}-yes>_{MsgBoolYes}
+
+  <div .radio>
+    <input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
+    <label for=#{theId}-no>_{MsgBoolNo}

templates/widgets/link-email.hamlet

@@ -1,2 +1,3 @@
-<a href="mailto:#{userEmail}">
+$# Used for all mailto-link, and used as both as shamlet and whamlet at once.
-  #{userEmail}
+<a href="mailto:#{email}">
+  ^{linkText}

templates/widgets/modal/modal.julius

@@ -1,7 +1,9 @@
 document.addEventListener('DOMContentLoaded', function() {
-  // TODO: replace for loop with one precise query for this specific modal instance
+  var modalIdent = #{String modalId};
-  var modalElements = Array.from(document.querySelectorAll('.modal'));
+  var selector = '#modal-' + modalIdent;
-  modalElements.forEach(function(modal) {
+  var modal = document.querySelector(selector);
+
+  if (modal) {
     window.utils.setup('modal', modal);
-  });
+  }
 });

templates/widgets/permutation/permutation.hamlet

@@ -1,5 +1,5 @@
 $newline never
-<ul ##{theId}>
+<ul ##{theId} .list--iconless>
   $forall (n, selId) <- nums
     <li>
       <select ##{selId} name=#{name} :isReq:required *{attrs}>

templates/widgets/register-form/register-form.hamlet

@@ -2,6 +2,12 @@ $# extra protects us against CSRF
 #{extra}
 $# Maybe display textField for passcode
 $maybe secretView <- msecretView
+  ^{fvLabel secretView}
   ^{fvInput secretView}
+$# Ask for associated primary field uf study, unless registered
+$maybe sfView <- msfView
+  ^{fvLabel sfView}
+  ^{fvInput sfView}
+
 $# Always display register/deregister button
 ^{fvInput btnView}

test/Database.hs

@@ -93,6 +93,7 @@ fillDb = do
   gkleen <- insert User
     { userIdent  = "G.Kleen@campus.lmu.de"
     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Just now
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
@@ -109,6 +110,7 @@ fillDb = do
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
@@ -125,6 +127,7 @@ fillDb = do
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
@@ -141,6 +144,7 @@ fillDb = do
   maxMuster <- insert User
     { userIdent  = "max@campus.lmu.de"
     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Just now
     , userMatrikelnummer = Just "1299"
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
@@ -157,6 +161,7 @@ fillDb = do
   tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Nothing
     , userMatrikelnummer = Just "999"
     , userEmail  = "tester@campus.lmu.de"
     , userDisplayName = "Tina Tester"
@@ -198,7 +203,7 @@ fillDb = do
     , termActive       = True
     }
   ifi <- insert' $ School "Institut für Informatik" "IfI"
-  mi <- insert' $ School "Institut für Mathematik" "MI"
+  mi  <- insert' $ School "Institut für Mathematik" "MI"
   void . insert' $ UserAdmin gkleen ifi
   void . insert' $ UserAdmin gkleen mi
   void . insert' $ UserAdmin fhamann ifi
@@ -210,13 +215,150 @@ fillDb = do
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88
+    sdLAR = StudyDegreeKey' 33
+    sdLAG = StudyDegreeKey' 35
   repsert sdBsc  $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
   repsert sdMst  $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+  repsert sdLAR  $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown
+  repsert sdLAG  $ StudyDegree 35 Nothing      Nothing -- intentionally left unknown
   let
     sdInf  = StudyTermsKey' 79
     sdMath = StudyTermsKey' 105
-  repsert sdInf  $ StudyTerms  79 (Just "IfI") (Just "Institut für Informatik")
+    sdMedi = StudyTermsKey' 121
-  repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
+    sdPhys = StudyTermsKey' 128
+    sdBioI1 = StudyTermsKey' 221
+    sdBioI2 = StudyTermsKey' 228
+    sdBiol  = StudyTermsKey' 26
+    sdChem1 = StudyTermsKey' 61
+    sdChem2 = StudyTermsKey' 113
+    sdBWL   = StudyTermsKey' 21
+    sdDeut  = StudyTermsKey' 103
+  repsert sdInf   $ StudyTerms  79 (Just "Inf")   (Just "Informatikk")
+  repsert sdMath  $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")
+  repsert sdMedi  $ StudyTerms 121  Nothing       (Just "Fehler hier")
+  repsert sdPhys  $ StudyTerms 128  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBioI1 $ StudyTerms 221  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBioI2 $ StudyTerms 228  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBiol  $ StudyTerms 26   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdChem1 $ StudyTerms 61   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdChem2 $ StudyTerms 113  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBWL   $ StudyTerms 21   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdDeut  $ StudyTerms 103  Nothing        Nothing                  -- intentionally left unknown
+  incidence1 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence1 221 "Mathematik"
+  void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence1 105 "Mathematik"
+  incidence2 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence2 221 "Chemie"
+  void . insert $ StudyTermCandidate incidence2 61  "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence2 61  "Chemie"
+  incidence3 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence3 113 "Chemie"
+  incidence4 <- liftIO getRandom  -- ambiguous incidence
+  void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence4 221 "Chemie"
+  void . insert $ StudyTermCandidate incidence4 221 "Biologie"
+  void . insert $ StudyTermCandidate incidence4 61  "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence4 61  "Chemie"
+  void . insert $ StudyTermCandidate incidence4 61  "Biologie"
+  void . insert $ StudyTermCandidate incidence4 61  "Chemie"
+  void . insert $ StudyTermCandidate incidence4 26  "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence4 26  "Chemie"
+  void . insert $ StudyTermCandidate incidence4 26  "Biologie"
+  incidence5 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence5 228 "Physik"
+  void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence5 128 "Physik"
+  incidence6 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence6 228 "Physik"
+  void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence6 128 "Physik"
+  incidence7 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence7 228 "Physik"
+  void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence7 128 "Physik"
+  void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik"
+  incidence8 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence8 128 "Physik"
+  void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik"
+  void . insert $ StudyTermCandidate incidence8 121 "Physik"
+  void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik"
+  incidence9 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence9 79 "Informatik"
+  incidence10 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence10 103  "Deutsch"
+  void . insert $ StudyTermCandidate incidence10 103  "Betriebswirtschaftslehre"
+  void . insert $ StudyTermCandidate incidence10 21   "Deutsch"
+  void . insert $ StudyTermCandidate incidence10 21   "Betriebswirtschaftslehre"
+  incidence11 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence11 221 "Chemie"
+  void . insert $ StudyTermCandidate incidence11 221 "Biologie"
+  void . insert $ StudyTermCandidate incidence11 61  "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence11 61  "Chemie"
+  void . insert $ StudyTermCandidate incidence11 61  "Biologie"
+  void . insert $ StudyTermCandidate incidence11 26  "Bioinformatik"
+  void . insert $ StudyTermCandidate incidence11 26  "Chemie"
+  void . insert $ StudyTermCandidate incidence11 26  "Biologie"
+  incidence12 <- liftIO getRandom
+  void . insert $ StudyTermCandidate incidence12 103  "Deutsch"
+  void . insert $ StudyTermCandidate incidence12 103  "Betriebswirtschaftslehre"
+  void . insert $ StudyTermCandidate incidence12 21   "Deutsch"
+  void . insert $ StudyTermCandidate incidence12 21   "Betriebswirtschaftslehre"
+
+  sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
+    maxMuster
+    sdBsc
+    sdInf
+    FieldPrimary
+    2
+    now
+    True
+  sfMMs <- insert $ StudyFeatures
+    maxMuster
+    sdBsc
+    sdMath
+    FieldSecondary
+    2
+    now
+    True
+  _sfTTa <- insert $ StudyFeatures
+    tinaTester
+    sdBsc
+    sdInf
+    FieldPrimary
+    4
+    now
+    False
+  sfTTb <- insert $ StudyFeatures
+    tinaTester
+    sdLAG
+    sdPhys
+    FieldPrimary
+    1
+    now
+    True
+  sfTTc <- insert $ StudyFeatures
+    tinaTester
+    sdLAR
+    sdMedi
+    FieldPrimary
+    7
+    now
+    True
+  _sfTTd <- insert $ StudyFeatures
+    tinaTester
+    sdMst
+    sdMath
+    FieldPrimary
+    3
+    now
+    True
+
   -- FFP
   let nbrs :: [Int]
       nbrs = [1,2,3,27,7,1]
@@ -224,15 +366,15 @@ fillDb = do
     { courseName = "Fortgeschrittene Funktionale Programmierung"
     , courseDescription = Just [shamlet|
         <h2>It is fun!
-          <p>Come to where the functional is!
+        <p>Come to where the functional is!
-          <section>
+        <section>
-            <h3>Functional programming can be done in Haskell!
+          <h3>Functional programming can be done in Haskell!
-            <p>This is not a joke, this is serious!
+          <p>This is not a joke, this is serious!
-          <section>
+        <section>
-            <h3>Consider some numbers
+          <h3>Consider some numbers
-            <ul>
+          <ul>
-              $forall n <- nbrs
+            $forall n <- nbrs
-                <li>Number #{n}
+              <li>Number #{n}
         |]
     , courseLinkExternal = Nothing
     , courseShorthand = "FFP"
@@ -256,6 +398,12 @@ fillDb = do
   insert_ $ SheetEdit gkleen now feste
   keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
   insert_ $ SheetEdit gkleen now keine
+  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
+    [(fhamann   , Nothing)
+    ,(maxMuster , Just sfMMs)
+    ,(tinaTester, Just sfTTc)
+    ]
+
   -- EIP
   eip <- insert' Course
     { courseName = "Einführung in die Programmierung"
@@ -328,7 +476,11 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo
-  void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester]
+  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
+    [(fhamann   , Nothing)
+    ,(maxMuster , Just sfMMp)
+    ,(tinaTester, Just sfTTb)
+    ]
   sh1 <- insert Sheet
     { sheetCourse = pmo
     , sheetName = "Blatt 1"
@@ -376,8 +528,8 @@ fillDb = do
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
     , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
+    , courseRegisterSecret  = Just "dbs"
-    , courseMaterialFree    = True
+    , courseMaterialFree    = False
     }
   insert_ $ CourseEdit gkleen now dbs
   void . insert' $ DegreeCourse dbs sdBsc sdInf

test/ModelSpec.hs

@@ -40,6 +40,7 @@ instance Arbitrary User where
       , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
       ]
     userAuthentication <- arbitrary
+    userLastAuthentication <- arbitrary
     userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
     userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
 
@@ -60,7 +61,7 @@ instance Arbitrary User where
     userDownloadFiles <- arbitrary
     userMailLanguages <- arbitrary
     userNotificationSettings <- arbitrary
-    
+
     return User{..}
   shrink = genericShrink
 
@@ -71,7 +72,7 @@ instance Arbitrary File where
     fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
     fileContent <- arbitrary
     return File{..}
-    where 
+    where
       inZipRange :: UTCTime -> Bool
       inZipRange time
         | time > UTCTime (fromGregorian 1980 1 1) 0

test/TestImport.hs

@@ -92,7 +92,7 @@ authenticateAs (Entity _ User{..}) = do
     setMethod "GET"
     addRequestHeader ("Accept-Language", "de")
     setUrl $ AuthR LoginR
-  
+
   request $ do
     setMethod "POST"
     addToken_ "#login--dummy"
@@ -107,6 +107,7 @@ createUser adjUser = do
   let
     userMatrikelnummer = Nothing
     userAuthentication = AuthLDAP
+    userLastAuthentication = Nothing
     userIdent = "dummy@example.invalid"
     userEmail = "dummy@example.invalid"
     userDisplayName = "Dummy Example"