Merge branch 'master' into feat/wrapform

.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.

clean.sh

@@ -0,0 +1,29 @@
+#!/usr/bin/env bash
+
+case $1 in
+    "")
+        exec -- stack clean
+        ;;
+    *)
+        target=".stack-work-${1}"
+        if [[ ! -d "${target}" ]]; then
+            printf "%s does not exist or is no directory\n" "${target}" >&2
+            exit 1
+        fi
+        if [[ -e .stack-work-clean ]]; then
+            printf ".stack-work-clean exists\n" >&2
+            exit 1
+        fi
+
+        move-back() {
+            mv -v .stack-work "${target}"
+            [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work
+        }
+
+        mv -v .stack-work .stack-work-clean
+        mv -v "${target}" .stack-work
+        trap move-back EXIT
+
+        stack clean
+        ;;
+esac

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,8 +71,8 @@ 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}
 CourseName: Name
 CourseDescription: Beschreibung
 CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@@ -87,6 +89,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
@@ -252,8 +255,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)
 
@@ -340,6 +345,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
@@ -401,8 +407,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
@@ -654,3 +680,6 @@ DeleteConfirmation: Bestätigung
 DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
 
 DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
+
+MassInputAddDimension: Hinzufügen
+MassInputDeleteCell: Entfernen

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,44 +1,68 @@
--- Some comments needes
+-- The files in /models determine the database scheme.
-User json
+-- The organisational split into several files has no operational effects.
-    ident          (CI Text)
+-- White-space and case matters: Each SQL table is named in 1st column of this file
-    authentication AuthenticationMode
+-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
-    matrikelnummer Text Maybe
+-- Nullable columns have "Maybe" written after their type
-    email          (CI Text)
+-- Option "default=xyz" is only used for database migrations due to changes in the SQL-schema, also see Model.Migration
-    displayName    Text
+-- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
-    surname        Text            -- always use: nameWidget displayName surname
+-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
-    maxFavourites  Int default=12
+--
-    theme          Theme default='Default'
+User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
-    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
+    ident          (CI Text)                -- Case-insensitive user-identifier
-    dateFormat     DateTimeFormat "default='%d.%m.%Y'"
+    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
-    timeFormat     DateTimeFormat "default='%R'"
+    lastAuthentication UTCTime Maybe        -- last login date
-    downloadFiles  Bool default=false
+    matrikelnummer Text Maybe               -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
-    mailLanguages  MailLanguages default='[]'
+    email          (CI Text)                -- Case-insensitive eMail address
-    notificationSettings NotificationSettings
+    displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
-    UniqueAuthentication ident
+    surname        Text                     -- Display user names always through 'nameWidget displayName surname'
-    UniqueEmail email
+    maxFavourites  Int default=12           -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
-    deriving Show Eq Generic
+    theme          Theme default='Default'  -- Color-theme of the frontend; user-defined
-UserAdmin
+    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  -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester
+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
+    valid         Bool default=true       -- marked as active in LDAP (students may switch, but LDAP never forgets)
+    UniqueStudyFeatures user degree field type semester
+    -- UniqueUserSubject ubuser degree field -- There exists a counterexample
 StudyDegree   -- Studienabschluss
-    key           Int
+    key           Int            -- LMU-internal key
-    shorthand     Text Maybe
+    shorthand     Text Maybe     -- admin determined shorthand
-    name          Text Maybe
+    name          Text Maybe     -- description given by LDAP
-    Primary key
+    Primary key                  -- column key is used as actual DB row key
+                                 -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
+    deriving Show
 StudyTerms    -- Studiengang
-    key           Int
+    key           Int            -- LMU-internal key
-    shorthand     Text Maybe
+    shorthand     Text Maybe     -- admin determined shorthand
-    name          Text Maybe
+    name          Text Maybe     -- description given by LDAP
-    Primary key
+    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

@@ -114,6 +114,7 @@ dependencies:
   - memcached-binary
   - directory-tree
   - lifted-base
+  - lattices
   - hsass
 
 other-extensions:
@@ -170,6 +171,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
@@ -220,7 +222,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
@@ -251,6 +253,32 @@ instance RenderMessage UniWorX SheetType where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
+instance RenderMessage UniWorX StudyDegree where
+  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
+
+newtype ShortStudyDegree = ShortStudyDegree StudyDegree
+
+instance RenderMessage UniWorX ShortStudyDegree where
+  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
+
+instance RenderMessage UniWorX StudyTerms where
+  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
+
+newtype ShortStudyTerms = ShortStudyTerms StudyTerms
+
+instance RenderMessage UniWorX ShortStudyTerms where
+  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
+
+data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
+
+instance RenderMessage UniWorX StudyDegreeTerm where
+  renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")"
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+
+
 newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
 embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 
@@ -307,6 +335,7 @@ data instance ButtonClass UniWorX
   | BCWarning
   | BCDanger
   | BCLink
+  | BCMassInputAdd | BCMassInputDelete
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 instance Universe (ButtonClass UniWorX)
 instance Finite (ButtonClass UniWorX)
@@ -1021,6 +1050,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
@@ -1032,9 +1062,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
@@ -1072,9 +1106,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)
@@ -1102,10 +1139,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)
@@ -1127,7 +1166,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]
@@ -1246,6 +1285,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
+      }
   ]
 
 
@@ -1267,33 +1314,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
@@ -1914,6 +2003,8 @@ instance YesodAuth UniWorX where
         $(widgetFile "login")
 
     authenticate Creds{..} = runDB $ do
+      now <- liftIO getCurrentTime
+
       let
         userIdent = CI.mk credsIdent
         uAuth = UniqueAuthentication userIdent
@@ -1941,7 +2032,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
@@ -1960,6 +2056,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'
@@ -2000,16 +2097,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"
@@ -2017,15 +2116,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

@@ -2,24 +2,46 @@ module Handler.Admin where
 
 import Import
 import Handler.Utils
+import Handler.Utils.Form.MassInput
 import Jobs
-
 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 Data.Char (isDigit)
+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 = identForm FIDAdminDemo $ \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
@@ -77,23 +99,20 @@ makeDemoForm n = identForm FIDAdminDemo $ \html -> do -- Important: used identFo
 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>
@@ -126,6 +145,61 @@ postAdminTestR = do
                     <li>#{m}
         |]
 
+
+  {- The following demonstrates the use of @massInput@.
+
+     @massInput@ takes as arguments:
+       - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
+       - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
+       - An initial value to pre-fill the field with
+
+     @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
+   -}
+  let
+    -- We define the fields of the configuration struct @MassInput@:
+
+    -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
+    --
+    -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required)
+    mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
+              -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
+              -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
+              -> FieldView UniWorX -- ^ Submit-Button for this add-widget
+              -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell
+    mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
+      (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
+      let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
+          addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required
+      return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
+    mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
+
+    -- | Make a single massInput-Cell
+    --
+    -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
+    mkCellForm :: ListPosition -- ^ Position of this cell
+               -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
+               -> Maybe Int -- ^ Initial cell result from Argument to `massInput`
+               -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
+               -> Form Int
+    mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
+      (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
+      return (intRes, toWidget csrf >> fvInput intView)
+    -- | How does the shape (`ListLength`) change if a certain cell is deleted?
+    deleteCell :: ListLength -- ^ Current shape
+               -> ListPosition -- ^ Coordinate to delete
+               -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
+    deleteCell l pos
+      | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
+      | otherwise = return Map.empty
+    -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
+    allowAdd :: ListPosition -> Natural -> ListLength -> Bool
+    allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
+
+  -- The actual call to @massInput@ is comparatively simple:
+    
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing
+
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
@@ -142,6 +216,22 @@ postAdminTestR = do
       }
     showDemoResult
 
+    [whamlet|
+      <h2>Mass-Input
+      <form enctype=#{miEnc} method=POST>
+        ^{miForm}
+        ^{submitButtonView}
+      $case miResult
+        $of FormMissing
+        $of FormFailure errs
+          <ul>
+            $forall err <- errs
+              <li>#{err}
+        $of FormSuccess res
+          <p style="white-space:pre-wrap; font-family:monospace;">
+            #{tshow res}
+    |]
+
 
 getAdminErrMsgR, postAdminErrMsgR :: Handler Html
 getAdminErrMsgR = postAdminErrMsgR
@@ -161,3 +251,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
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
     $(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, UTCTime, 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
@@ -654,44 +712,84 @@ _userTableRegistration = _dbrOutput . _2
 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
 _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 _, _, 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 i18nCell . view (_userTableFeatures . _3)
+
+colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
+    foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
+
+colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
+    foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
+
+colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
+    foldMap (i18nCell . 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      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId)
+      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,19 +798,21 @@ getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCUsersR tid ssh csh = do
   Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
   let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
-      whereClause = courseIs cid
       colChoices  = mconcat
-        [ colUserParticipantLink tid ssh csh
+        [ colUserNameLink (CourseR tid ssh csh . CUserR)
         , colUserEmail
         , colUserMatriclenr
-        , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
+        , colUserDegreeShort
+        , colUserField
+        , colUserSemester
+        , sortable (Just "course-registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
         , colUserComment tid ssh csh
         ]
-      psValidator = def
+      psValidator = def & defaultSortingByName
-  tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator
+  tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
   siteLayout heading $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-    -- TODO: creat hamlet wrapper
+    -- TODO: create hamlet wrapper
     tableWidget
 
 

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
@@ -193,7 +193,7 @@ deleteUser duid = do
 getProfileDataR :: Handler Html
 getProfileDataR = do
   (uid, User{..}) <- requireAuthPair
-  --   mr <- getMessageRender
+  -- MsgRenderer mr <- getMsgRenderer
   (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
     E.select
       ( E.from $ \(adright `E.InnerJoin` school) -> do
@@ -222,14 +222,7 @@ getProfileDataR = do
           E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
           E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
           E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-          return  ( ( studydegree E.^. StudyDegreeName
+          return  (studyfeat, studydegree, studyterms)
-                      , studydegree E.^. StudyDegreeKey
-                      )
-                  , ( studyterms  E.^. StudyTermsName
-                      , studyterms  E.^. StudyTermsKey
-                      )
-                  , studyfeat   E.^. StudyFeaturesType
-                  , studyfeat   E.^. StudyFeaturesSemester)
       )
   (   (hasRows, ownedCoursesTable)
     , enrolledCoursesTable
@@ -248,6 +241,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,10 +7,14 @@ 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
 import Handler.Utils.Table as Handler.Utils
@@ -39,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
@@ -59,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
 
 warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
 warnTermDays tid times = do

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

@@ -215,6 +215,44 @@ 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)
+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)
+    MsgRenderer mr <- getMsgRenderer
+    mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) 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 :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
+    procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do
+      cfid <- encrypt sfid
+      return Option
+        { optionDisplay = mr $ StudyDegreeTerm sdegree sterm
+        , 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
 
@@ -482,6 +520,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
@@ -541,42 +603,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
@@ -631,5 +657,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/Form/MassInput.hs

@@ -0,0 +1,352 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Handler.Utils.Form.MassInput
+  ( MassInput(..)
+  , massInput
+  , BoxDimension(..)
+  , IsBoxCoord(..), boxDimension
+  , Liveliness(..)
+  , ListLength(..), ListPosition(..)
+  ) where
+
+import Import
+import Utils.Form
+import Utils.Lens
+import Handler.Utils.Form (secretJsonField)
+
+import Data.Aeson
+
+import Algebra.Lattice
+
+import Text.Blaze (Markup)
+
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.Foldable as Fold
+import Data.List (genericLength, genericIndex, iterate)
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Reader.Class (MonadReader(local))
+import Control.Monad.Fix
+
+
+data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
+  
+class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
+  boxDimensions :: [BoxDimension x]
+  boxOrigin :: x
+
+boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
+boxDimension n
+  | n < genericLength dims = genericIndex dims n
+  | otherwise = error "boxDimension: insufficient dimensions"
+  where
+    dims = boxDimensions
+
+-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
+-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
+  
+class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
+  type BoxCoord a :: *
+  liveCoords :: Prism' (Set (BoxCoord a)) a
+  liveCoord :: BoxCoord a -> Prism' Bool a
+  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
+
+
+newtype ListLength = ListLength { unListLength :: Natural }
+  deriving newtype (Num, Integral, Real, Enum, PathPiece)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''ListLength
+
+instance JoinSemiLattice ListLength where
+  (\/) = max
+instance MeetSemiLattice ListLength where
+  (/\) = min
+instance Lattice ListLength
+instance BoundedJoinSemiLattice ListLength where
+  bottom = 0
+
+newtype ListPosition = ListPosition { unListPosition :: Natural }
+  deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''ListPosition
+
+instance IsBoxCoord ListPosition where
+  boxDimensions = [BoxDimension id]
+  boxOrigin = 0
+
+instance Liveliness ListLength where
+  type BoxCoord ListLength = ListPosition
+  liveCoords = prism' toSet fromSet
+    where
+      toSet n
+        | n > 0     = Set.fromList [0..pred (fromIntegral n)]
+        | otherwise = Set.empty
+
+      fromSet ns
+        | ns == maybe Set.empty (\n -> Set.fromList [0..n]) max'
+        = fmap (succ . fromIntegral) max' <|> Just 0
+        | otherwise
+        = Nothing
+        where
+          max' = Set.lookupMax ns
+  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
+
+data ButtonMassInput coord
+  = MassInputAddDimension Natural coord
+  | MassInputDeleteCell coord
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance PathPiece coord => PathPiece (ButtonMassInput coord) where
+  toPathPiece = \case
+    MassInputAddDimension n c -> "add__" <> toPathPiece n <> "__" <> toPathPiece c
+    MassInputDeleteCell c -> "delete__" <> toPathPiece c
+  fromPathPiece t = addDim <|> delCell
+    where
+      addDim = do
+        (dimT, Text.stripPrefix "__" -> Just coordT) <- Text.breakOn "__" <$> stripPrefix "add__" t
+        MassInputAddDimension <$> fromPathPiece dimT <*> fromPathPiece coordT
+      delCell = do
+        coordT <- stripPrefix "delete__" t
+        MassInputDeleteCell <$> fromPathPiece coordT
+
+instance RenderMessage UniWorX (ButtonMassInput coord) where
+  renderMessage f ls = \case
+    MassInputAddDimension _ _ -> mr MsgMassInputAddDimension
+    MassInputDeleteCell _ -> mr MsgMassInputDeleteCell
+    where
+      mr = renderMessage f ls
+
+instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where
+  btnValidate _ _ = False
+
+  btnClasses (MassInputAddDimension _ _) = [BCIsButton, BCDefault, BCMassInputAdd]
+  btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning, BCMassInputDelete]
+
+
+data MassInputFieldName coord
+  = MassInputShape { miName :: Text }
+  | MassInputAddWidget { miName :: Text, miCoord :: coord, miAddWidgetField :: Text }
+  | MassInputAddButton { miName :: Text, miCoord :: coord }
+  | MassInputDeleteButton { miName :: Text, miCoord :: coord }
+  | MassInputCell { miName :: Text, miCoord :: coord, miCellField :: Text }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
+  toPathPiece = \case
+    MassInputShape{..} -> [st|#{miName}__shape|]
+    MassInputAddWidget{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__fields__#{miAddWidgetField}|]
+    MassInputAddButton{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__submit|]
+    MassInputDeleteButton{..} -> [st|#{miName}__delete__#{toPathPiece miCoord}|]
+    MassInputCell{..} -> [st|#{miName}__cells__#{toPathPiece miCoord}__#{miCellField}|]
+
+  fromPathPiece t = do
+    (miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t
+    choice
+      [ do
+          guard $ t' == "shape"
+          return MassInputShape{..}
+      , do
+          t'' <- Text.stripPrefix "add__" t'
+          (coordT, Text.stripPrefix "__" -> Just rest) <- return $ Text.breakOn "__" t''
+          miAddWidgetField <- Text.stripPrefix "fields__" rest
+          miCoord <- fromPathPiece coordT
+          return MassInputAddWidget{..}
+      , do
+          t'' <- Text.stripPrefix "add__" t'
+          (coordT, Text.stripPrefix "__" -> Just ident) <- return $ Text.breakOn "__" t''
+          guard $ ident == "submit"
+          miCoord <- fromPathPiece coordT
+          return MassInputAddButton{..}
+      , do
+          t'' <- Text.stripPrefix "delete__" t'
+          (coordT, rest) <- return $ Text.breakOn "__" t''
+          guard $ Text.null rest
+          miCoord <- fromPathPiece coordT
+          return MassInputDeleteButton{..}
+      , do
+          t'' <- Text.stripPrefix "cells__" t'
+          (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t''
+          miCoord <- fromPathPiece coordT
+          return MassInputCell{..}
+      ]
+
+data MassInputException = MassInputInvalidShape
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception MassInputException
+
+data MassInput handler liveliness cellData cellResult = MassInput
+  { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
+          -> Natural -- Zero-based dimension index @dimIx@
+          -> (Text -> Text) -- Nudge deterministic field ids
+          -> FieldView UniWorX -- Submit button
+          -> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
+  , miCell :: BoxCoord liveliness -- Position
+           -> cellData -- @cellData@ from @miAdd@
+           -> Maybe cellResult -- Initial result from Argument to @massInput@
+           -> (Text -> Text) -- Nudge deterministic field ids
+           -> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
+  , miDelete :: liveliness
+             -> BoxCoord liveliness
+             -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
+  , miAllowAdd :: BoxCoord liveliness
+               -> Natural
+               -> liveliness
+               -> Bool -- ^ Decide whether an addition-operation should be permitted
+  }
+
+massInput :: forall handler cellData cellResult liveliness.
+           ( MonadHandler handler, HandlerSite handler ~ UniWorX
+           , ToJSON cellData, FromJSON cellData
+           , Liveliness liveliness
+           , MonadFix handler, MonadLogger handler
+           )
+          => MassInput handler liveliness cellData cellResult
+          -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
+          -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
+massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
+  let initialShape = fmap fst <$> initialResult
+  
+  miName <- maybe newFormIdent return fsName
+  let
+    shapeName :: MassInputFieldName (BoxCoord liveliness)
+    shapeName = MassInputShape{..}
+    shapeField = secretJsonField
+  sentShape <- runMaybeT $ do
+    ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
+    fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
+    MaybeT $ either (const Nothing) id <$> lift (fieldParse shapeField ts fs)
+  sentShape' <- if
+    | Just s <- sentShape -> return s
+    | Just iS <- initialShape -> return iS
+    | Set.null $ review liveCoords (bottom :: liveliness) -> return Map.empty
+    | otherwise -> throwM MassInputInvalidShape
+  sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
+
+  let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (liveliness -> (BoxCoord liveliness, cellData))), Maybe Widget))
+      addForm = addForm' boxOrigin . zip [0..]
+        where
+          addForm' _ [] = return Map.empty
+          addForm' miCoord ((dimIx, _) : remDims) = do
+            let nudgeAddWidgetName :: Text -> Text
+                nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing
+            let btnRes
+                  | FormSuccess  Nothing <- btnRes' = FormMissing
+                  | FormSuccess (Just x) <- btnRes' = FormSuccess x
+                  | otherwise                       = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes'
+            addRes' <- over (mapped . _Just . _1) (btnRes *>) . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
+                  miAdd miCoord dimIx nudgeAddWidgetName btnView
+            let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
+            case remDims of
+              [] -> return dimRes'
+              ((_, BoxDimension dim) : _) -> do
+                let
+                  miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
+                dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
+                return $ dimRes' `Map.union` fold dimRess
+
+  addResults <- addForm boxDimensions
+  let addShape
+        | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
+        = Just $ maybe id (uncurry Map.insert) (mkResult sentLiveliness <$ guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
+        | otherwise = Nothing
+
+  addedShape <- if
+    | Just s <- addShape -> return s
+    | otherwise -> return sentShape'
+  addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
+
+  let
+    delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
+    delForm miCoord = do
+      (delRes, delView) <- lift $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing
+      shapeUpdate <- miDelete addedLiveliness miCoord
+      guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
+      return (shapeUpdate <$ delRes, delView)
+
+  delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
+  let
+    delShapeUpdate
+        | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
+        | otherwise = Nothing
+    delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
+
+
+  let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
+
+  shape <- if
+    | Just s <- addShape -> return s 
+    | Just s <- delShape -> return s 
+    | otherwise          -> return sentShape'
+  liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+
+  shapeId <- newIdent
+  let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
+
+
+  let
+    applyDelShapeUpdate :: Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
+    applyDelShapeUpdate prevEnv
+      | Just delShapeUpdate' <- delShapeUpdate
+      , Just (env, fEnv) <- prevEnv
+      = let reverseUpdate = Map.fromList . map swap $ Map.toList delShapeUpdate'
+         in Just . (, fEnv) . flip (Map.mapKeysWith mappend) env $ \k -> fromMaybe k $ do
+              cell@MassInputCell{miCoord} <- fromPathPiece k
+              newCoord <- Map.lookup miCoord reverseUpdate
+              return $ toPathPiece cell{ miCoord = newCoord }
+      | otherwise = prevEnv
+
+    justAdded :: Set (BoxCoord liveliness)
+    justAdded = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults
+      where
+        addedCoord res
+          | FormSuccess (Just mkResult) <- res
+          = Just . fst $ mkResult sentLiveliness
+          | otherwise = Nothing
+    restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a
+    restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded)
+
+  cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
+    let
+      nudgeCellName :: Text -> Text
+      nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
+    local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
+  let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
+      result
+        | shapeChanged = FormMissing
+        | otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
+
+  let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+      miWidget' _ [] = mempty
+      miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+        let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+            cells
+              | [] <- remDims = do
+                  coord <- coords
+                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
+                  let deleteButton = snd <$> Map.lookup coord delResults
+                  return (coord, $(widgetFile "widgets/massinput/cell"))
+              | otherwise =
+                  [ (coord, miWidget' coord remDims) | coord <- coords ]
+            addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
+         in $(widgetFile "widgets/massinput/row")
+
+      miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
+
+  MsgRenderer mr <- getMsgRenderer
+  fvId <- maybe newIdent return fsId
+  
+  let
+    fvLabel = toHtml $ mr fsLabel
+    fvTooltip = toHtml . mr <$> fsTooltip
+    fvInput = $(widgetFile "widgets/massinput/massinput")
+    fvErrors = Nothing
+    in return (result, FieldView{..})

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,10 @@ import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
 
+import Numeric.Natural.Instances as Import ()
+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,8 @@ import Data.Aeson (Value)
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
 
-import Utils.Message (MessageClass)
+import Utils.Message (MessageStatus)
+
 import Settings.Cluster (ClusterSettingsKey)
 
 import Data.Binary (Binary)

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/Numeric/Natural/Instances.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Numeric.Natural.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Numeric.Natural
+import Web.PathPieces
+
+instance PathPiece Natural where
+  toPathPiece = tshow
+  fromPathPiece = readMay

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

@@ -25,8 +25,7 @@ import Utils.PathPiece as Utils
 import Utils.Route 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)
 
@@ -34,13 +33,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(..))
@@ -67,6 +69,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
 import Data.Fixed (Centi)
 import Data.Ratio ((%))
 
+{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
+
 
 
 -----------
@@ -141,6 +145,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 --
 ---------------------
@@ -251,6 +260,21 @@ stepTextCounter text
 -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
 -- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]
 
+-- | Ignore warnings for unused variables with a more specific type
+notUsedT :: a -> Text
+notUsedT = notUsed
+
+
+
+------------
+-- Monoid --
+------------
+
+-- | Ignore warnings for unused variables
+notUsed :: Monoid m => a -> m
+notUsed = const mempty
+
+
 ------------
 -- Tuples --
 ------------
@@ -302,6 +326,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 --
 ----------
@@ -322,6 +357,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 --
@@ -455,8 +501,6 @@ throwExceptT :: ( Exception e, MonadThrow m )
              => ExceptT e m a -> m a
 throwExceptT = exceptT throwM return
 
-
-
 ------------
 -- Monads --
 ------------
@@ -478,7 +522,7 @@ assertM f x = x >>= assertM' f
 assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
 assertM_ f x = guard . f =<< x
 
-assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' :: Alternative m => (a -> Bool) -> a -> m a
 assertM' f x = x <$ guard (f x)
 
 -- Some Utility Functions from Agda.Utils.Monad
@@ -531,6 +575,12 @@ mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
 mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
 mconcatForM = flip mconcatMapM
 
+-----------------
+-- Alternative --
+-----------------
+
+choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a
+choice = foldr (<|>) empty
 
 --------------
 -- Sessions --
@@ -556,32 +606,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 ((!!))
 
@@ -100,8 +104,8 @@ addClass = addAttr "class"
 addClasses :: [Text] -> FieldSettings site -> FieldSettings site
 addClasses = addAttrs "class"
 
-addName :: Text -> FieldSettings site -> FieldSettings site
+addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
-addName nm fs = fs { fsName = Just nm }
+addName nm fs = fs { fsName = Just $ toPathPiece nm }
 
 addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
 addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
@@ -147,7 +151,70 @@ inputReadonly = addAttr "readonly" ""
 addAutosubmit :: FieldSettings site -> FieldSettings site
 addAutosubmit = addAttr "data-autosubmit" ""
 
+------------------------------------------------
+-- Unique Form Identifiers to avoid accidents --
+------------------------------------------------
 
+data FormIdentifier
+  = FIDcourse
+  | FIDcourseRegister
+  | FIDsheet
+  | FIDsubmission
+  | FIDsettings
+  | FIDcorrectors
+  | FIDcorrectorTable
+  | FIDcorrection
+  | FIDcorrectionsUpload
+  | FIDcorrectionUpload
+  | FIDSystemMessageAdd
+  | FIDSystemMessageTable
+  | FIDSystemMessageModify
+  | FIDSystemMessageModifyTranslation UUID
+  | FIDSystemMessageAddTranslation
+  | FIDDBTableFilter
+  | FIDDBTablePagesize
+  | FIDDBTable
+  | FIDDelete
+  | FIDCourseRegister
+  deriving (Eq, Ord, Read, Show)
+
+instance PathPiece FormIdentifier where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+
+identifyForm' :: (Monad m, PathPiece ident, Eq ident)
+              => Lens' x (FormResult a)
+              -> ident -- ^ Form identification
+              -> (Html -> MForm m (x, widget))
+              -> (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
+  - nur einmal pro makeForm reicht
+-}
 
 ----------------------------
 -- Buttons (new version ) --
@@ -348,50 +415,6 @@ optionsFinite = do
   return . mkOptionList $ mkOption <$> universeF
 
 
-
-------------------------------------------------
--- Unique Form Identifiers to avoid accidents --
-------------------------------------------------
-
-data FormIdentifier
-  = FIDcourse
-  | FIDsheet
-  | FIDsubmission
-  | FIDsettings
-  | FIDcorrectors
-  | FIDcorrectorTable
-  | FIDcorrection
-  | FIDcorrectionsUpload
-  | FIDcorrectionUpload
-  | FIDSystemMessageAdd
-  | FIDSystemMessageTable
-  | FIDSystemMessageModify
-  | FIDSystemMessageModifyTranslation UUID
-  | FIDSystemMessageAddTranslation
-  | FIDDBTableFilter
-  | FIDDBTablePagesize
-  | FIDDelete
-  | FIDAdminDemo
-  deriving (Eq, Ord, Read, Show)
-
-instance PathPiece FormIdentifier where
-  fromPathPiece = readFromPathPiece
-  toPathPiece = showToPathPiece
-
-
-identForm :: (Monad m, PathPiece ident)
-          => ident -- ^ Form identification
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-identForm = identifyForm . toPathPiece
-
-{- Hinweise zur Erinnerung:
-  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
-  - nur einmal pro makeForm reicht
--}
-
-
-
 -----------
 -- Forms --
 -----------
@@ -559,4 +582,48 @@ 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)
+
+mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
+mpreq f fs mx = do
+  mr <- getMessageRender
+  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\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,17 @@ makeLenses_ ''SheetType
 
 makePrisms ''AuthResult
 
+makePrisms ''FormResult
+
+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,61 @@
         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() {},
+    };
+  }
+
+  // Override implicit submit (pressing enter) behaviour to trigger a specified submit button instead of the default
+  window.utils.implicitSubmit = function(input, options) {
+    var submit = options.submit;
+
+    console.log('implicitSubmit', input, submit);
+
+    if (!submit) {
+      throw new Error('window.utils.implicitSubmit(input, options) needs to be passed a submit element via options');
+    }
+
+    var doSubmit = function(event) {
+      if (event.keyCode == 13) {
+        event.preventDefault();
+        submit.click();
+      }
+    };
+
+    input.addEventListener('keypress', doSubmit);
+    
+    return {
+      scope: input,
+      destroy: function() {
+        input.removeEventListener('keypress', doSubmit);
+      },
+    };
+  }
 })();

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/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/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>
@@ -39,25 +45,23 @@
         <div .scrolltable>
           <table .table.table--striped.table--hover.table--condensed>
             <tr .table__row>
-              <th .table__th> Abschluss
               <th .table__th> Studiengang
+              <th .table__th> Abschluss
               <th .table__th> Studienart
               <th .table__th> Semester
+              <th .table__th> Aktiv
+              <th .table__th> Update
 
-            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
+
+            $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
+              $with _ <- notUsedT studyFeaturesUser
               <tr.table__row>
-                <td .table__td>
+                <td .table__td>_{field}#{notUsedT studyFeaturesField}
-                  $maybe name <- E.unValue degree
+                <td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
-                    #{display name}
+                <td .table__td>_{studyFeaturesType}
-                  $nothing
+                <td .table__td>#{display studyFeaturesSemester}
-                    #{display degreeKey}
+                <td .table__td>#{hasTickmark studyFeaturesValid}
-                <td .table__td>
+                <td .table__td>^{formatTimeW SelFormatDateTime studyFeaturesUpdated}
-                  $maybe name <- E.unValue field
-                    #{display name}
-                  $nothing
-                    #{display fieldKey}
-                <td .table__td>_{E.unValue fieldtype}
-                <td .table__td>#{display semester}
 
   <div .container>
     $if hasRows

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/massinput/cell.hamlet

@@ -0,0 +1,3 @@
+^{cellWdgt}
+$maybe delWdgt <- fmap fvInput deleteButton
+  ^{delWdgt}

templates/widgets/massinput/massinput.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<div .massinput ##{fvId}>
+  #{csrf}
+  ^{shapeInput}
+  ^{miWidget}

templates/widgets/massinput/massinput.julius

@@ -0,0 +1,21 @@
+document.addEventListener('DOMContentLoaded', function() {
+  var form = document.getElementById(#{String fvId}).closest('form');
+
+
+  var formSubmit = form.querySelector('input[type=submit], button[type=submit]:not(.btn-mass-input-add):not(.btn-mass-input-delete)');
+  var cellInputs = Array.from(form.querySelectorAll('.massinput--cell input:not([type=hidden])'));
+
+  cellInputs.forEach(function(input) {
+    window.utils.setup('implicitSubmit', input, { submit: formSubmit });
+  });
+
+
+  Array.from(form.querySelectorAll('.massinput--add')).forEach(function(wrapper) {
+    var addSubmit = wrapper.querySelector('.btn-mass-input-add');
+    var addInputs = Array.from(wrapper.querySelectorAll('input:not([type=hidden]):not(.btn-mass-input-add)'));
+
+    addInputs.forEach(function(input) {
+      window.utils.setup('implicitSubmit', input, { submit: addSubmit });
+    });
+  });
+});

templates/widgets/massinput/row.hamlet

@@ -0,0 +1,7 @@
+<ul .massinput--row .#{"massinput--dim" <> toPathPiece dimIx}>
+  $forall (cellCoord, cell) <- cells
+    <li .massinput--cell data-massinput-coord=#{toPathPiece cellCoord}>
+      ^{cell}
+  $maybe add <- addWidget
+    <li .massinput--add>
+      ^{add}

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/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}