diff --git a/.hlint.yaml b/.hlint.yaml index b9203d95b..ecd17c599 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -1,5 +1,5 @@ -# HLint configuration file -# https://github.com/ndmitchell/hlint +# HLint configuration file +# 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 diff --git a/ChangeLog.md b/ChangeLog.md index 59d7755a2..c1ce2db41 100644 --- a/ChangeLog.md +++ b/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 diff --git a/RoleDescriptions.txt b/RoleDescriptions.txt new file mode 100644 index 000000000..054b6a3d5 --- /dev/null +++ b/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 diff --git a/build.sh b/build.sh index 991d2ff3c..13a8b2490 100755 --- a/build.sh +++ b/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. diff --git a/db.sh b/db.sh index bb9685550..8861a2ac4 100755 --- a/db.sh +++ b/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 -- $@ diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b7ceb8948..2297642d8 100644 --- a/messages/uniworx/de.msg +++ b/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} -CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} +CourseMembersCount n@Int: #{display n} +CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max} CourseName: Name CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet @@ -253,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) @@ -341,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 @@ -402,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 diff --git a/models/config b/models/config index 33bcaf8d6..5ec2357d6 100644 --- a/models/config +++ b/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 - value Value + 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 -- JSON-encoded value Primary setting \ No newline at end of file diff --git a/models/courses b/models/courses index 96bba0195..fb9b06462 100644 --- a/models/courses +++ b/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 - linkExternal Text Maybe - shorthand (CI Text) - term TermId + description Html Maybe -- user-defined large Html, ought to contain module description + linkExternal Text Maybe -- arbitrary user-defined url for external course page + shorthand (CI Text) -- practical shorthand of course name, used for identification + 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 - registerTo UTCTime Maybe - deregisterUntil UTCTime Maybe - registerSecret Text Maybe -- Falls ein Passwort erforderlich ist - materialFree Bool - TermSchoolCourseShort term school shorthand - TermSchoolCourseName term school name + registerFrom UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited + registerTo UTCTime Maybe -- enrolement may be prohibited from a given date onwards + deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards + registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase + materialFree Bool -- False: only enrolled users may see course materials not stored in this table + TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester + 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 - user UserId - time UTCTime +CourseFavourite -- which user accessed which course when, only displayed to user for convenience; + user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User" + time UTCTime -- oldest is removed first course CourseId UniqueCourseFavourite user course deriving Show -Lecturer +Lecturer -- course ownership user UserId course CourseId - UniqueLecturer user course -CourseParticipant + UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table +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 diff --git a/models/exams b/models/exams index e356e4221..f9d326011 100644 --- a/models/exams +++ b/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 - statisticsVisible Bool + ratingVisible Bool -- may participants see their own rating yet + statisticsVisible Bool -- may participants view statistics over all participants (should not be allowed for 'small' courses) --ExamEdit -- user UserId -- time UTCTime diff --git a/models/files b/models/files index 62a5ffe72..f96745687 100644 --- a/models/files +++ b/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 diff --git a/models/jobs b/models/jobs index 15f7bb7dc..fcf0006b8 100644 --- a/models/jobs +++ b/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 - creationInstance InstanceId + 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 -- multiple uni2work-instances access the same database, record which instance created this job for debugging purposes creationTime UTCTime - lockInstance InstanceId Maybe - lockTime UTCTime Maybe + lockInstance InstanceId Maybe -- instance that has started to execute this job + 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 - time UTCTime - instance InstanceId + job Value -- JSON-encoded description of work done + time UTCTime -- When was the job executed + instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job diff --git a/models/rooms b/models/rooms index 7b62d41f5..2ef670fd3 100644 --- a/models/rooms +++ b/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 diff --git a/models/schools b/models/schools index 6b73e1c27..f877a1aeb 100644 --- a/models/schools +++ b/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 diff --git a/models/sheets b/models/sheets index 8fd75eae1..e13fc2d47 100644 --- a/models/sheets +++ b/models/sheets @@ -1,39 +1,43 @@ -Sheet +Sheet -- exercise sheet for a given course course CourseId name (CI Text) description Html Maybe - type SheetType - grouping SheetGroup - markingText Html Maybe - visibleFrom UTCTime Maybe - activeFrom UTCTime - activeTo UTCTime - hintFrom UTCTime Maybe - solutionFrom UTCTime Maybe - uploadMode UploadMode - submissionMode SheetSubmissionMode default='UserSubmissions' - autoDistribute Bool default=false + type SheetType -- Does it count towards overall course grade? + grouping SheetGroup -- May participants submit in groups of certain sizes? + markingText Html Maybe -- Instructions for correctors, included in marking templates + visibleFrom UTCTime Maybe -- Invisible to enrolled participants before + activeFrom UTCTime -- Download of questions and submission is permitted afterwards + activeTo UTCTime -- Submission is only permitted before + hintFrom UTCTime Maybe -- Additional files are made available + solutionFrom UTCTime Maybe -- Solution is made available + uploadMode UploadMode -- Take apart Zip-Archives or not? + submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only? + 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 - state CorrectorState default='CorrectorNormal' + load Load -- portion of work that will be assigned to this corrector + 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 diff --git a/models/submissions b/models/submissions index ff998b845..e8ea0d049 100644 --- a/models/submissions +++ b/models/submissions @@ -1,34 +1,34 @@ -Submission +Submission -- submission for marking by a CourseParticipant sheet SheetId - ratingPoints Points Maybe -- "Just" does not mean done - ratingComment Text 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; not yet visible to participant ratingBy UserId Maybe -- assigned corrector - ratingAssigned UTCTime Maybe -- time assigned corrector - ratingTime UTCTime Maybe -- "Just" here indicates done! + ratingAssigned UTCTime Maybe -- time when corrector was assigned + ratingTime UTCTime Maybe -- "Just" here indicates done; marking is made visible to participant deriving Show Generic -SubmissionEdit - user UserId +SubmissionEdit -- user uploads new version of their submission + 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) - isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector + isUpdate Bool -- is this the file updated by a corrector (original will always be retained) + isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile file submission isUpdate deriving Show -SubmissionUser -- Actual submission participant +SubmissionUser -- which submission belongs to whom user UserId submission SubmissionId - UniqueSubmissionUser user submission -SubmissionGroup + UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups +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 diff --git a/models/system-messages b/models/system-messages index 0ceec9223..f2692ab64 100644 --- a/models/system-messages +++ b/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 - to UTCTime Maybe - authenticatedOnly Bool - severity MessageStatus - defaultLanguage Lang - content Html + from UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null) + to UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null) + authenticatedOnly Bool -- Show message to all users upon visiting the site or only upon login? + severity MessageStatus -- Success, Warning, Error, Info, ... + defaultLanguage Lang -- Language of @content@ and @summary@ + 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 diff --git a/models/terms b/models/terms index 698a6a6d1..1ca1daae7 100644 --- a/models/terms +++ b/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] - lectureStart Day - lectureEnd Day - active Bool + holidays [Day] -- LMU holidays, for display in timetables + lectureStart Day -- lectures usually start/end later/earlier than the actual term, + lectureEnd Day -- used to generate warnings for lecturers creating unusual courses + 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 diff --git a/models/tutorials b/models/tutorials index 51e20b195..3afed739e 100644 --- a/models/tutorials +++ b/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 diff --git a/models/users b/models/users index f93b954d4..80e5ff43c 100644 --- a/models/users +++ b/models/users @@ -1,44 +1,68 @@ --- Some comments needes -User json - ident (CI Text) - authentication AuthenticationMode - matrikelnummer Text Maybe - email (CI Text) - displayName Text - surname Text -- always use: nameWidget displayName surname - maxFavourites Int default=12 - theme Theme default='Default' - dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" - dateFormat DateTimeFormat "default='%d.%m.%Y'" - timeFormat DateTimeFormat "default='%R'" - downloadFiles Bool default=false - mailLanguages MailLanguages default='[]' - notificationSettings NotificationSettings - UniqueAuthentication ident - UniqueEmail email - deriving Show Eq Generic -UserAdmin +-- The files in /models determine the database scheme. +-- The organisational split into several files has no operational effects. +-- White-space and case matters: Each SQL table is named in 1st column of this file +-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options +-- Nullable columns have "Maybe" written after their type +-- Option "default=xyz" is only used for database migrations due to changes in the SQL-schema, also see Model.Migration +-- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns. +-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname +-- +User json -- Each Uni2work user has a corresponding row in this table; created upon first login. + ident (CI Text) -- Case-insensitive user-identifier + authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) + lastAuthentication UTCTime Maybe -- last login date + matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) + email (CI Text) -- Case-insensitive eMail address + displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) + surname Text -- Display user names always through 'nameWidget displayName surname' + maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined + theme Theme default='Default' -- Color-theme of the frontend; user-defined + dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined + dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined + timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined + downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) + mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined + notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined + UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table + UniqueEmail email -- Column 'email' can be used as a row-key in this table + deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory +UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user user UserId school SchoolId - UniqueUserAdmin user school -UserLecturer + UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows +UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user user UserId school SchoolId - UniqueSchoolLecturer user school -StudyFeatures -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester + UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows +StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login user UserId - degree StudyDegreeId - field StudyTermsId - type StudyFieldType + degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. + field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. + 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 - shorthand Text Maybe - name Text Maybe - Primary key + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } + deriving Show StudyTerms -- Studiengang - key Int - shorthand Text Maybe - name Text Maybe - Primary key + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } + deriving Show +StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. + -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. + -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. + -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations + incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs + key Int -- a possible key for the studyTermName + name Text -- studyTermName as plain text from LDAP + deriving Show Eq Ord diff --git a/package.yaml b/package.yaml index 138efc9ac..83b3b006e 100644 --- a/package.yaml +++ b/package.yaml @@ -171,6 +171,7 @@ default-extensions: ghc-options: - -Wall - -fno-warn-type-defaults + - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures when: diff --git a/routes b/routes index 1a9f35659..9b15ab3b9 100644 --- a/routes +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 58fa1a09a..899047c3b 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 41464cc00..2dab7cf8d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,8 +1,19 @@ -module Database.Esqueleto.Utils where +{-# OPTIONS_GHC -fno-warn-orphans #-} -import ClassyPrelude.Yesod hiding (isInfixOf, (||.)) -import Data.Foldable as F -import Database.Esqueleto as E +module Database.Esqueleto.Utils + ( true, false + , 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) -any test = F.foldr (\needle acc -> acc ||. test needle) false + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +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) -all test = F.foldr (\needle acc -> acc &&. test needle) true + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +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 \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs new file mode 100644 index 000000000..5596f31ee --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 70ad9da14..4295f1179 100644 --- a/src/Foundation.hs +++ b/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 @@ -1077,9 +1079,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 AdminTestR = return ("Test" , Just HomeR) + breadcrumb UsersR = return ("Benutzer" , Just AdminR) 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) @@ -1107,10 +1112,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 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 (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh 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) @@ -1132,7 +1139,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] @@ -1251,6 +1258,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 + } ] @@ -1272,33 +1287,75 @@ pageActions (HomeR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuAdminTest + { menuItemType = PageActionPrime + , 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 @@ -1919,6 +1976,8 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate Creds{..} = runDB $ do + now <- liftIO getCurrentTime + let userIdent = CI.mk credsIdent uAuth = UniqueAuthentication userIdent @@ -1946,7 +2005,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 @@ -1965,6 +2029,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' @@ -2005,16 +2070,18 @@ instance YesodAuth UniWorX where , userMailLanguages = def , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail - ] + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , 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" @@ -2022,15 +2089,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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a79faabb9..3713c8e1e 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -4,30 +4,43 @@ 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 Database.Persist.Sql (fromSqlKey) - -import qualified Data.Text as Text -import Data.Char (isDigit) - -import qualified Data.Map as Map 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 -import Control.Monad.Trans.Writer (mapWriterT) + +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 @@ -43,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 = (,) @@ -167,7 +180,7 @@ postAdminTestR = do deleteCell l pos | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] | otherwise = return Map.empty - + ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell) "" True Nothing @@ -216,3 +229,160 @@ postAdminErrMsgR = do
^{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{..} + diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 222052f85..ab0d737bb 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 @@ -266,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) ) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6cc98cc64..838f81fe7 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -5,11 +5,16 @@ 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 @@ -26,7 +31,7 @@ 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 Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) @@ -103,10 +108,10 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) 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 - [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] + (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do + [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do 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 (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration) + return ( E.countRows :: E.SqlExpr (E.Value Int)) + return (course,school E.^. SchoolName, numParticipants, participant) + defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) - return (course,schoolName,participants,registered,lecturers) + 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 - (regWidget, regEnctype) <- generateFormPost $ identifyForm FIDCourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course + mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration + (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 -registerForm registered msecret extra = do - (msecretRes', msecretView) <- case msecret of - (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing - _ -> return (Nothing,Nothing) - (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing - let widget = $(widgetFile "widgets/register-form/register-form") - let msecretRes | Just res <- msecretRes' = Just <$> res - | otherwise = FormSuccess Nothing - return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes + let widget = $(widgetFile "widgets/register-form/register-form") + let msecretRes | Just res <- msecretRes' = Just <$> res + | otherwise = FormSuccess Nothing + let msfRes | Just res <- msfRes' = res + | otherwise = FormSuccess Nothing + -- checks that correct button was pressed, and ignores result of btnRes + let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes) + return (formRes, widget) + where + 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) - return (cid, course, registered) - ((regResult,_), _) <- runFormPost $ identifyForm FIDCourseRegister $ registerForm registered $ courseRegisterSecret course - case regResult of - (FormSuccess codeOk) - | registered -> do + registration <- getBy (UniqueParticipant aid cid) + return (cid, course, entityVal <$> registration) + let isRegistered = isJust registration + ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course + formResult regResult $ \(mbSfId,codeOk) -> if + | 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 @@ -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 UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) -type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId) +type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) + `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 = id +-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) +-- forceUserTableType = id -userTableQuery :: UserTableWhere -> UserTableExpr - -> E.SqlQuery ( E.SqlExpr (Entity User) - , E.SqlExpr (E.Value UTCTime) - , E.SqlExpr (E.Value (Maybe CourseUserNoteId))) -userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do +-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions) +-- This ought to ease refactoring the query +queryUser :: UserTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +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 - return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId) + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + 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 -courseIs :: CourseId -> UserTableWhere -courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid +_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) +_userTableFeatures = _dbrOutput . _4 + +_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) - $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } -> + sortable (Just "note") (i18nCell MsgCourseUserNote) + $ \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) => - -- UserTableWhere - -- -> Colonnade - -- 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 +colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $ + foldMap numCell . preview _rowUserSemester -makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget -makeCourseUserTable whereClause colChoices psValidator = - -- return [whamlet|TODO|] -- TODO +colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $ + foldMap htmlCell . view (_userTableFeatures . _3) + +colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $ + foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3) + +colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $ + foldMap htmlCell . preview (_userTableFeatures . _2 . _Just) + +colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ + foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just) + +makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget +makeCourseUserTable cid colChoices psValidator = -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text - dbtStyle = def - dbtSQLQuery = userTableQuery whereClause - dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId) + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtSQLQuery = userTableQuery cid + dbtRowKey = queryUser >>> (E.^. UserId) + 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 - dbtFilter = Map.fromList [] -- TODO - dbtFilterUI = mempty -- TODO + dbtSorting = Map.fromList + [ sortUserNameLink queryUser -- slower sorting through clicking name column header + , 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 - tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator + psValidator = def & defaultSortingByName + tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator siteLayout heading $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] - -- TODO: creat hamlet wrapper + -- TODO: create hamlet wrapper tableWidget diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 5b767b1fe..f615d3899 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -248,6 +248,8 @@ getProfileDataR = do let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] + lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication + -- Delete Button (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) defaultLayout $ do diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index 386fe0983..83b299a94 100644 --- a/src/Handler/Utils/Database.hs +++ b/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) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cbaed2eaf..b9409d059 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,6 +214,47 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName +-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user) +-- (too many special cases, hence not used in course registration anymore) +studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) +studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do + -- we need a join, so we cannot just use optionsPersistCryptoId + rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do + E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId + E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId + E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) + E.||. isPrimaryActiveUserStudyFeature feature + return (feature E.^. StudyFeaturesId, degree, field) + mr <- getMessageRender + mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM procOptions rawOptions + where + isPrimaryActiveUserStudyFeature feature = case mbuid of + Nothing -> E.val False + (Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid + E.&&. feature E.^. StudyFeaturesValid E.==. E.val True + E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + + procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId)) + procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do + let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName) + stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName ) + cfid <- encrypt sfid + return Option + { optionDisplay = stname <> " (" <> dgname <> ")" + , optionInternalValue = Just sfid + , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) + } + + nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)] + nonEmptyOptions emptyOpt opts + | null opts = [ Option + { optionDisplay = emptyOpt + , optionInternalValue = Nothing + , optionExternalValue = "NoPrimaryStudyField" + } ] + | otherwise = opts + + uploadModeField :: Field Handler UploadMode uploadModeField = selectField optionsFinite diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 9dbce258a..d2903309c 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -8,12 +8,12 @@ import Text.Parsec import Text.Parsec.Text -parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] -parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" +parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures] +parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) "" - -pStudyFeatures :: UserId -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser = do + +pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] +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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index dc86454dd..7abd6b4d7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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 @@ -167,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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs new file mode 100644 index 000000000..52e8b5dfe --- /dev/null +++ b/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) + + diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 741117297..2247512ad 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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) @@ -652,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 @@ -665,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) @@ -869,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) - => Lens' res (FormResult (DBFormResult i a (DBRow r))) - -> (DBRow r -> MForm (HandlerT UniWorX IO) i) +formCell :: forall x r i a. (Ord i, Monoid x) + => 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) -- ^ 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) @@ -896,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) - => Lens' res (FormResult (DBFormResult i a (DBRow r))) +dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x) + => 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 diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 44648cf21..187c679a6 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/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) diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs new file mode 100644 index 000000000..5eeba9a56 --- /dev/null +++ b/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 + + + diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 68e6d1c92..39de96dd7 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -62,6 +62,8 @@ 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) diff --git a/src/Model.hs b/src/Model.hs index 4a0e3f1c9..3fabff444 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -19,7 +19,9 @@ import Data.Aeson (Value) import Data.CaseInsensitive (CI) import Data.CaseInsensitive.Instances () +import Text.Blaze (ToMarkup, toMarkup, Markup) import Utils.Message (MessageStatus) + import Settings.Cluster (ClusterSettingsKey) import Data.Binary (Binary) @@ -41,3 +43,20 @@ deriving instance Binary (Key Term) submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +-- Do these instances belong here? +instance ToMarkup StudyDegree where + toMarkup StudyDegree{..} = toMarkup $ + fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand) + +shortStudyDegree :: StudyDegree -> Markup +shortStudyDegree StudyDegree{..} = toMarkup $ + fromMaybe (tshow studyDegreeKey) studyDegreeShorthand + +instance ToMarkup StudyTerms where + toMarkup StudyTerms{..} = toMarkup $ + fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand) + +shortStudyTerms :: StudyTerms -> Markup +shortStudyTerms StudyTerms{..} = toMarkup $ + fromMaybe (tshow studyTermsKey) studyTermsShorthand diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index ac11d3241..7b5fcc375 100644 --- a/src/Model/Migration.hs +++ b/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" = '' |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 94655817d..52fd5ed32 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index fa4ec109c..e91a97a5b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -24,23 +24,24 @@ import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils import Utils.Lang as Utils -import Control.Lens as Utils (none) import Utils.Parameters as Utils - import Text.Blaze (Markup, ToMarkup) 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(..)) @@ -160,6 +161,11 @@ hasTickmark :: Bool -> Markup hasTickmark True = [shamlet||] hasTickmark False = mempty +isNew :: Bool -> Markup +isNew True = [shamlet||] +isNew False = mempty + + --------------------- -- Text and String -- --------------------- @@ -321,6 +327,17 @@ mergeAttrs = mergeAttrs' `on` sort +---------- +-- Sets -- +---------- + +-- | Intersection of multiple sets. Returns empty set for empty input list +setIntersections :: Ord a => [Set a] -> Set a +setIntersections [] = Set.empty +setIntersections (h:t) = foldl' Set.intersection h t + + + ---------- -- Maps -- ---------- @@ -341,6 +358,17 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList +--------------- +-- Functions -- +--------------- + +-- curryN, uncurryN see Utils.TH + +-- | Just @flip (.)@ for convenient formatting in some cases, +-- Deprecated in favor of Control.Arrow.(>>>) +compose :: (a -> b) -> (b -> c) -> (a -> c) +compose = flip (.) + ----------- -- Maybe -- @@ -474,8 +502,6 @@ throwExceptT :: ( Exception e, MonadThrow m ) => ExceptT e m a -> m a throwExceptT = exceptT throwM return - - ------------ -- Monads -- ------------ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 049217701..c82f02226 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -198,6 +198,7 @@ addAutosubmit = addAttr "data-autosubmit" "" data FormIdentifier = FIDcourse + | FIDcourseRegister | FIDsheet | FIDsubmission | FIDsettings diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index dcb8f6590..0abc9a8ee 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -82,6 +82,15 @@ makePrisms ''AuthResult makePrisms ''FormResult +makeLenses_ ''StudyFeatures + +makeLenses_ ''StudyDegree + +makeLenses_ ''StudyTerms + +makeLenses_ ''StudyTermCandidate + + -- makeClassy_ ''Load diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index ea1e73b3c..b12d90359 100644 --- a/src/Utils/TH.hs +++ b/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 - where pat = tupP (map varP xs) - rhs = varE (xs !! (i - 1)) - xs = [ mkName $ "x" ++ show j | j <- [1..n] ] +projNI n i = do + x <- newName "x" + let rhs = varE x + let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP + lamE [pat] rhs + + +-- | 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 -- diff --git a/start.sh b/start.sh index 24abcd36c..b72d043c2 100755 --- a/start.sh +++ b/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 diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet new file mode 100644 index 000000000..bda21478b --- /dev/null +++ b/templates/adminFeatures.hamlet @@ -0,0 +1,19 @@ +
+ ^{degreeTable} +
+ ^{studytermsTable} +
+

_{MsgStudyFeatureInference} +

+ $if null infConflicts + Kein Konflikte beobachtet. + $else +

Studiengangseingträge mit beobachteten Konflikten: +
    + $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts +
  • #{show ky} - #{foldMap id nm} + + ^{btnWdgt} + +
    + ^{candidateTable} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 175f98f3d..3360b0afa 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -10,6 +10,12 @@
    #{display userEmail}
    _{MsgIdent}
    #{display userIdent} +
    _{MsgLastLogin} +
    + $maybe llogin <- lastLogin + #{llogin} + $nothing + _{MsgNever} $if not $ null admin_rights
    Administrator
    diff --git a/templates/widgets/register-form/register-form.hamlet b/templates/widgets/register-form/register-form.hamlet index a2dd97af9..c9a9fa1a3 100644 --- a/templates/widgets/register-form/register-form.hamlet +++ b/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} diff --git a/test/Database.hs b/test/Database.hs index daef8d28a..c3b83c636 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -93,6 +93,7 @@ fillDb = do gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" , userAuthentication = AuthLDAP + , userLastAuthentication = Just now , userMatrikelnummer = Nothing , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" @@ -109,6 +110,7 @@ fillDb = do fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" @@ -125,6 +127,7 @@ fillDb = do jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing , userMatrikelnummer = Nothing , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" @@ -141,6 +144,7 @@ fillDb = do maxMuster <- insert User { userIdent = "max@campus.lmu.de" , userAuthentication = AuthLDAP + , userLastAuthentication = Just now , userMatrikelnummer = Just "1299" , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" @@ -157,6 +161,7 @@ fillDb = do tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing , userMatrikelnummer = Just "999" , userEmail = "tester@campus.lmu.de" , userDisplayName = "Tina Tester" @@ -198,7 +203,7 @@ fillDb = do , termActive = True } ifi <- insert' $ School "Institut für Informatik" "IfI" - mi <- insert' $ School "Institut für Mathematik" "MI" + mi <- insert' $ School "Institut für Mathematik" "MI" void . insert' $ UserAdmin gkleen ifi void . insert' $ UserAdmin gkleen mi void . insert' $ UserAdmin fhamann ifi @@ -210,13 +215,150 @@ fillDb = do let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88 + sdLAR = StudyDegreeKey' 33 + sdLAG = StudyDegreeKey' 35 repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) + repsert sdLAR $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown + repsert sdLAG $ StudyDegree 35 Nothing Nothing -- intentionally left unknown let sdInf = StudyTermsKey' 79 sdMath = StudyTermsKey' 105 - repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") - repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") + sdMedi = StudyTermsKey' 121 + sdPhys = StudyTermsKey' 128 + sdBioI1 = StudyTermsKey' 221 + sdBioI2 = StudyTermsKey' 228 + sdBiol = StudyTermsKey' 26 + sdChem1 = StudyTermsKey' 61 + sdChem2 = StudyTermsKey' 113 + sdBWL = StudyTermsKey' 21 + sdDeut = StudyTermsKey' 103 + repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk") + repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik") + repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier") + repsert sdPhys $ StudyTerms 128 Nothing Nothing -- intentionally left unknown + repsert sdBioI1 $ StudyTerms 221 Nothing Nothing -- intentionally left unknown + repsert sdBioI2 $ StudyTerms 228 Nothing Nothing -- intentionally left unknown + repsert sdBiol $ StudyTerms 26 Nothing Nothing -- intentionally left unknown + repsert sdChem1 $ StudyTerms 61 Nothing Nothing -- intentionally left unknown + repsert sdChem2 $ StudyTerms 113 Nothing Nothing -- intentionally left unknown + repsert sdBWL $ StudyTerms 21 Nothing Nothing -- intentionally left unknown + repsert sdDeut $ StudyTerms 103 Nothing Nothing -- intentionally left unknown + incidence1 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik" + void . insert $ StudyTermCandidate incidence1 221 "Mathematik" + void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik" + void . insert $ StudyTermCandidate incidence1 105 "Mathematik" + incidence2 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik" + void . insert $ StudyTermCandidate incidence2 221 "Chemie" + void . insert $ StudyTermCandidate incidence2 61 "Bioinformatik" + void . insert $ StudyTermCandidate incidence2 61 "Chemie" + incidence3 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence3 113 "Chemie" + incidence4 <- liftIO getRandom -- ambiguous incidence + void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik" + void . insert $ StudyTermCandidate incidence4 221 "Chemie" + void . insert $ StudyTermCandidate incidence4 221 "Biologie" + void . insert $ StudyTermCandidate incidence4 61 "Bioinformatik" + void . insert $ StudyTermCandidate incidence4 61 "Chemie" + void . insert $ StudyTermCandidate incidence4 61 "Biologie" + void . insert $ StudyTermCandidate incidence4 61 "Chemie" + void . insert $ StudyTermCandidate incidence4 26 "Bioinformatik" + void . insert $ StudyTermCandidate incidence4 26 "Chemie" + void . insert $ StudyTermCandidate incidence4 26 "Biologie" + incidence5 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik" + void . insert $ StudyTermCandidate incidence5 228 "Physik" + void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik" + void . insert $ StudyTermCandidate incidence5 128 "Physik" + incidence6 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik" + void . insert $ StudyTermCandidate incidence6 228 "Physik" + void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik" + void . insert $ StudyTermCandidate incidence6 128 "Physik" + incidence7 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence7 228 "Physik" + void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik" + void . insert $ StudyTermCandidate incidence7 128 "Physik" + void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik" + incidence8 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence8 128 "Physik" + void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik" + void . insert $ StudyTermCandidate incidence8 121 "Physik" + void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik" + incidence9 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence9 79 "Informatik" + incidence10 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence10 103 "Deutsch" + void . insert $ StudyTermCandidate incidence10 103 "Betriebswirtschaftslehre" + void . insert $ StudyTermCandidate incidence10 21 "Deutsch" + void . insert $ StudyTermCandidate incidence10 21 "Betriebswirtschaftslehre" + incidence11 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik" + void . insert $ StudyTermCandidate incidence11 221 "Chemie" + void . insert $ StudyTermCandidate incidence11 221 "Biologie" + void . insert $ StudyTermCandidate incidence11 61 "Bioinformatik" + void . insert $ StudyTermCandidate incidence11 61 "Chemie" + void . insert $ StudyTermCandidate incidence11 61 "Biologie" + void . insert $ StudyTermCandidate incidence11 26 "Bioinformatik" + void . insert $ StudyTermCandidate incidence11 26 "Chemie" + void . insert $ StudyTermCandidate incidence11 26 "Biologie" + incidence12 <- liftIO getRandom + void . insert $ StudyTermCandidate incidence12 103 "Deutsch" + void . insert $ StudyTermCandidate incidence12 103 "Betriebswirtschaftslehre" + void . insert $ StudyTermCandidate incidence12 21 "Deutsch" + void . insert $ StudyTermCandidate incidence12 21 "Betriebswirtschaftslehre" + + sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here + maxMuster + sdBsc + sdInf + FieldPrimary + 2 + now + True + sfMMs <- insert $ StudyFeatures + maxMuster + sdBsc + sdMath + FieldSecondary + 2 + now + True + _sfTTa <- insert $ StudyFeatures + tinaTester + sdBsc + sdInf + FieldPrimary + 4 + now + False + sfTTb <- insert $ StudyFeatures + tinaTester + sdLAG + sdPhys + FieldPrimary + 1 + now + True + sfTTc <- insert $ StudyFeatures + tinaTester + sdLAR + sdMedi + FieldPrimary + 7 + now + True + _sfTTd <- insert $ StudyFeatures + tinaTester + sdMst + sdMath + FieldPrimary + 3 + now + True + -- FFP let nbrs :: [Int] nbrs = [1,2,3,27,7,1] @@ -256,6 +398,12 @@ fillDb = do insert_ $ SheetEdit gkleen now feste keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False insert_ $ SheetEdit gkleen now keine + void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf) + [(fhamann , Nothing) + ,(maxMuster , Just sfMMs) + ,(tinaTester, Just sfTTc) + ] + -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" @@ -328,7 +476,11 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo - void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester] + void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf) + [(fhamann , Nothing) + ,(maxMuster , Just sfMMp) + ,(tinaTester, Just sfTTb) + ] sh1 <- insert Sheet { sheetCourse = pmo , sheetName = "Blatt 1" @@ -376,8 +528,8 @@ fillDb = do , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True + , courseRegisterSecret = Just "dbs" + , courseMaterialFree = False } insert_ $ CourseEdit gkleen now dbs void . insert' $ DegreeCourse dbs sdBsc sdInf diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 33a54c2e3..258211f94 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -40,6 +40,7 @@ instance Arbitrary User where , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary ] userAuthentication <- arbitrary + userLastAuthentication <- arbitrary userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9']) userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary @@ -60,7 +61,7 @@ instance Arbitrary User where userDownloadFiles <- arbitrary userMailLanguages <- arbitrary userNotificationSettings <- arbitrary - + return User{..} shrink = genericShrink @@ -71,7 +72,7 @@ instance Arbitrary File where fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange fileContent <- arbitrary return File{..} - where + where inZipRange :: UTCTime -> Bool inZipRange time | time > UTCTime (fromGregorian 1980 1 1) 0 diff --git a/test/TestImport.hs b/test/TestImport.hs index 9d84e8722..f576ccf30 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -92,7 +92,7 @@ authenticateAs (Entity _ User{..}) = do setMethod "GET" addRequestHeader ("Accept-Language", "de") setUrl $ AuthR LoginR - + request $ do setMethod "POST" addToken_ "#login--dummy" @@ -107,6 +107,7 @@ createUser adjUser = do let userMatrikelnummer = Nothing userAuthentication = AuthLDAP + userLastAuthentication = Nothing userIdent = "dummy@example.invalid" userEmail = "dummy@example.invalid" userDisplayName = "Dummy Example"