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 129f9cc0c..b637608d6 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,9 +71,9 @@ CourseNewHeading: Neuen Kurs anlegen CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren CourseEditTitle: Kurs editieren/anlegen CourseMembers: Teilnehmer -CourseMembersCount num@Int64: #{display num} -CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} -CourseMembersCountOf num@Int64 mbNum@Int64Maybe: #{display num} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"} +CourseMembersCount n@Int: #{display n} +CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max} +CourseMembersCountOf n@Int mbNum@IntMaybe: #{display n} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"} CourseName: Name CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet @@ -88,6 +90,7 @@ CourseRegisterToTip: Anmeldung darf auch unbegrenzt offen bleiben CourseDeregisterUntilTip: Abmeldung darf auch unbegrenzt erlaubt bleiben CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseFilterNone: Egal CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? CourseDeleted: Kurs gelöscht CourseUserNote: Notiz @@ -253,8 +256,10 @@ Theme: Oberflächen Design Favoriten: Anzahl gespeicherter Favoriten Plugin: Plugin Ident: Identifikation +LastLogin: Letzter Login Settings: Individuelle Benutzereinstellungen SettingsUpdate: Einstellungen wurden gespeichert. +Never: Nie MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) @@ -341,6 +346,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter +AdminHeading: Administration AdminUserHeading: Benutzeradministration AccessRightsFor: Berechtigungen für AdminFor: Administrator @@ -402,8 +408,28 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. +AdminFeaturesHeading: Studiengänge +StudyFeatureInference: Studiengangschlüssel-Inferenz +StudyFeatureAge: Fachsemester +StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach FieldSecondary: Nebenfach +NoPrimaryStudyField: (kein Hauptfach registriert) + +DegreeKey: Schlüssel Abschluss +DegreeName: Abschluss +DegreeShort: Abschlusskürzel +StudyTermsKey: Schlüssel Studiengang +StudyTermsName: Studiengang +StudyTermsShort: Studiengangkürzel +StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert +StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert +StudyCandidateIncidence: Anmeldevorgang +AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt +RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt +CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert +NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert +StudyTermIsNew: Neu MailTestFormEmail: Email-Addresse MailTestFormLanguages: Spracheinstellungen @@ -626,12 +652,12 @@ MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten MenuAuthPreds: Authorisierungseinstellungen -AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate werden nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist (d.h. bis ihr Browser-Cookie abgelaufen ist). +AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator -AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert +AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung AuthTagLecturer: Nutzer ist Dozent @@ -646,7 +672,7 @@ AuthTagOwner: Nutzer ist Besitzer AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren -AuthTagAuthentication: Authentifizierung erfüllt Anforderungen +AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend 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 0547718ae..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 MessageClass - 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 5ac4a6a3c..80e5ff43c 100644 --- a/models/users +++ b/models/users @@ -1,43 +1,68 @@ -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 + 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 -StudyDegree - key Int - shorthand Text Maybe - name Text Maybe - Primary key -StudyTerms - key Int - shorthand Text Maybe - name Text Maybe - Primary key + 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 -- 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 -- 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 0aadd7a3f..70a0a0c90 100644 --- a/package.yaml +++ b/package.yaml @@ -170,6 +170,7 @@ default-extensions: ghc-options: - -Wall - -fno-warn-type-defaults + - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures when: 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/shell.nix b/shell.nix index 931e7ade0..e6178f7b0 100644 --- a/shell.nix +++ b/shell.nix @@ -1,11 +1,8 @@ -{ nixpkgs ? import {}, compiler ? null }: +{ nixpkgs ? import , compiler ? null }: let - inherit (nixpkgs) pkgs; - - haskellPackages = if isNull compiler - then pkgs.haskellPackages - else pkgs.haskell.packages."${compiler}"; + inherit (nixpkgs {}) pkgs; + haskellPackages = if isNull compiler then pkgs.haskellPackages else pkgs.haskell.packages."${compiler}"; drv = haskellPackages.callPackage ./uniworx.nix {}; @@ -26,21 +23,29 @@ let shellHook = '' export PROMPT_INFO="${oldAttrs.name}" - pgDir=$(mktemp -d) - pgSockDir=$(mktemp -d) - pgLogFile=$(mktemp) - initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700" - export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} - psql -f ${postgresSchema} postgres - printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} + if [[ -z "$PGHOST" ]]; then + set -xe - cleanup() { - pg_ctl stop -D ''${pgDir} - rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} - } + pgDir=$(mktemp -d) + pgSockDir=$(mktemp -d) + pgLogFile=$(mktemp) + initdb --no-locale -D ''${pgDir} + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700" + export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} + psql -f ${postgresSchema} postgres + printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} - trap cleanup EXIT + cleanup() { + set +e -x + pg_ctl stop -D ''${pgDir} + rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} + set +x + } + + trap cleanup EXIT + + set +xe + fi ${oldAttrs.shellHook} ''; 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 5d85229e1..6cc4d9a60 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 @@ -171,7 +173,7 @@ noneOneMoreDE num noneText singularForm pluralForm | otherwise = pluralForm -- Convenience Type for Messages -type Int64Maybe = Maybe Int64 -- Yesod messages cannot deal with compound type identifiers +type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers -- | Convenience function for i18n messages definitions maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text @@ -226,7 +228,7 @@ instance RenderMessage UniWorX MsgLanguage where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) -embedRenderMessage ''UniWorX ''MessageClass ("Message" <>) +embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id @@ -1027,6 +1029,7 @@ siteLayout' headingOverride widget = do addScript $ StaticR js_utils_asidenav_js addScript $ StaticR js_utils_asyncForm_js addScript $ StaticR js_utils_asyncTable_js + addScript $ StaticR js_utils_asyncTableFilter_js addScript $ StaticR js_utils_checkAll_js addScript $ StaticR js_utils_httpClient_js addScript $ StaticR js_utils_form_js @@ -1038,9 +1041,13 @@ siteLayout' headingOverride widget = do addStylesheet $ StaticR css_utils_alerts_scss addStylesheet $ StaticR css_utils_asidenav_scss addStylesheet $ StaticR css_utils_asyncForm_scss + addStylesheet $ StaticR css_utils_asyncTable_scss + addStylesheet $ StaticR css_utils_asyncTableFilter_scss + addStylesheet $ StaticR css_utils_checkbox_scss addStylesheet $ StaticR css_utils_form_scss addStylesheet $ StaticR css_utils_inputs_scss addStylesheet $ StaticR css_utils_modal_scss + addStylesheet $ StaticR css_utils_radio_scss addStylesheet $ StaticR css_utils_showHide_scss addStylesheet $ StaticR css_utils_tabber_scss addStylesheet $ StaticR css_utils_tooltip_scss @@ -1078,9 +1085,12 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) breadcrumb HomeR = return ("Uni2work" , Nothing) - breadcrumb UsersR = return ("Benutzer" , Just HomeR) - breadcrumb 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) @@ -1108,10 +1118,12 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) -- (CourseR tid ssh csh CRegisterR) -- is POST only - breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) - breadcrumb (CourseR tid ssh csh 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) @@ -1133,7 +1145,7 @@ instance YesodBreadcrumbs UniWorX where return $ if | mayList -> ("Statusmeldung", Just MessageListR) | otherwise -> ("Statusmeldung", Just HomeR) - breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) + breadcrumb (MessageListR) = return ("Statusmeldungen", Just AdminR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] @@ -1252,6 +1264,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgAdminHeading + , menuItemIcon = Just "screwdriver" + , menuItemRoute = SomeRoute AdminR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] @@ -1273,33 +1293,75 @@ pageActions (HomeR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime - , 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 @@ -1920,6 +1982,8 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate Creds{..} = runDB $ do + now <- liftIO getCurrentTime + let userIdent = CI.mk credsIdent uAuth = UniqueAuthentication userIdent @@ -1947,7 +2011,12 @@ instance YesodAuth UniWorX where return $ ServerError "LDAP lookup failed" ] - acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + acceptExisting = do + res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + _other -> return res $logDebugS "auth" $ tshow Creds{..} UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod @@ -1966,6 +2035,7 @@ instance YesodAuth UniWorX where userAuthentication | isPWHash = error "PWHash should only work for users that are already known" | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (not isDummy) userEmail <- if | Just [bs] <- userEmail' @@ -2006,16 +2076,18 @@ instance YesodAuth UniWorX where , userMailLanguages = def , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , 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" @@ -2023,15 +2095,28 @@ instance YesodAuth UniWorX where Right str <- return $ Text.decodeUtf8' v' return str + termNames = nubBy ((==) `on` CI.mk) $ do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFieldOfStudyString" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - lift $ deleteWhere [StudyFeaturesUser ==. userId] + let + studyTermCandidates = do + studyTermCandidateName <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs + return StudyTermCandidate{..} + lift $ insertMany_ studyTermCandidates - forM_ fs $ \StudyFeatures{..} -> do + lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] + forM_ fs $ \f@StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] - lift $ insertMany_ fs return $ Authenticated userId Nothing -> acceptExisting diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 501cc97b9..3eab2f26c 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,25 +1,47 @@ module Handler.Admin where import Import -import Handler.Utils import Jobs - +import Handler.Utils import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import Control.Monad.Trans.Except +import Control.Monad.Trans.Writer (mapWriterT) + +import Utils.Lens -- import Data.Time --- import qualified Data.Text as T +import qualified Data.Text as Text -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 +import qualified Data.Set as Set +import qualified Data.Map as Map + import Database.Persist.Sql (fromSqlKey) +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils as E + +import Handler.Utils.Table.Cells +import qualified Handler.Utils.TermCandidates as Candidates -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade -- import qualified Data.UUID.Cryptographic as UUID + + + +getAdminR :: Handler Html +getAdminR = -- do + siteLayoutMsg MsgAdminHeading $ do + setTitleI MsgAdminHeading + [whamlet| + This shall become the Administrators' overview page. + Its current purpose is to provide links to some important admin functions + |] + -- BEGIN - Buttons needed only here data ButtonCreate = CreateMath | CreateInf -- Dummy for Example deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) @@ -34,7 +56,7 @@ instance Button UniWorX ButtonCreate where btnClasses CreateMath = [BCIsButton, BCInfo] btnClasses CreateInf = [BCIsButton, BCPrimary] --- END Button needed here +-- END Button needed only here emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm = (,) @@ -55,7 +77,7 @@ emailTestForm = (,) SelFormatTime -> t makeDemoForm :: Int -> Form (Int,Bool,Double) -makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead! +makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ (,,) <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing <* aformSection MsgFormBehaviour @@ -76,23 +98,20 @@ makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used i getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate) + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" - ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm - case emailResult of - (FormSuccess (email, ls)) -> do - jId <- runDB $ do - jId <- queueJob $ JobSendTestEmail email ls - addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] - return jId - writeJobCtl $ JobCtlPerform jId - FormMissing -> return () - (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml + ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm + formResultModal emailResult AdminTestR $ \(email, ls) -> do + jId <- mapWriterT runDB $ do + jId <- queueJob $ JobSendTestEmail email ls + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + return jId + writeJobCtl $ JobCtlPerform jId let emailWidget' = [whamlet|
@@ -155,3 +174,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 2421a1b6a..ab0d737bb 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -85,22 +85,22 @@ submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) -- Columns -colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel -colSchool :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] -colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh) -colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> let tid = course ^. _3 @@ -109,16 +109,16 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] -colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet -colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname -colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> let csh = course ^. _2 @@ -134,7 +134,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId -colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let csh = course ^. _2 tid = course ^. _3 @@ -146,7 +146,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] @@ -170,26 +170,26 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E scribe (_2 :: Lens' (a, SheetTypeSummary) SheetTypeSummary) summary ] -colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty dateTimeCell submissionRatingAssigned -colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty dateTimeCell submissionRatingTime -colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> cell [whamlet|#{review _PseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) +colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) -colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) +colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of @@ -197,7 +197,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints) ) -colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) +colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -223,7 +223,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId - E.orderBy [E.asc $ user E.^. UserDisplayName] + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors @@ -237,6 +237,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d [ ( "term" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) @@ -263,7 +266,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.orderBy [E.asc $ user E.^. UserSurname] + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.limit 1 return (user E.^. UserSurname) ) @@ -350,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 + , dbParamsFormIdent = def } -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown) -- gradingSummary <- do @@ -611,13 +615,13 @@ postCorrectionR tid ssh csh shn cid = do (fslpI MsgRatingPoints "Punktezahl") (Just submissionRatingPoints) - ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) + ((corrResult, corrForm), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) <*> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <* submitButton - ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $ + ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $ areq (zipFileField True) (fslI MsgRatingFiles) Nothing <* submitButton @@ -690,7 +694,7 @@ getCorrectionUserR tid ssh csh shn cid = do getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do - ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $ + ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ areq (zipFileField True) (fslI MsgCorrUploadField) Nothing <* submitButton diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0985f7c28..ce9409ab7 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -5,14 +5,19 @@ module Handler.Course where import Import import Utils.Lens +import Utils.Form -- import Utils.DB import Handler.Utils -import Handler.Utils.Table.Cells import Handler.Utils.Course import Handler.Utils.Delete +import Handler.Utils.Database +import Handler.Utils.Table.Cells +import Handler.Utils.Table.Columns +import Database.Esqueleto.Utils +import Database.Esqueleto.Utils.TH -- import Data.Time -import qualified Data.Text as T +-- import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 @@ -26,9 +31,9 @@ import qualified Database.Esqueleto as E -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) +type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) -colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) @@ -46,12 +51,12 @@ colDescription = sortable Nothing mempty Nothing -> mempty (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr) -colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] --- colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +-- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) -- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend -- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) @@ -65,48 +70,48 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) -- |] -- ) -colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] -colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] -colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] -colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty dateTimeCell courseRegisterFrom -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget -colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty dateTimeCell courseRegisterTo -colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colMembers = sortable (Just "members") (i18nCell MsgCourseMembers) $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of Nothing -> MsgCourseMembersCount currentParticipants Just limit -> MsgCourseMembersCountLimited currentParticipants limit -colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) -course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64) +course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - return (E.countRows :: E.SqlExpr (E.Value Int64)) + return (E.countRows :: E.SqlExpr (E.Value Int)) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> @@ -263,8 +268,8 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do - [(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 - return $ user E.^. UserDisplayName - return (course,schoolName,participants,registered,map E.unValue lecturers) + 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,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 "registerBtn" $ 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 setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") +-- | Registration button with maybe a userid if logged in +-- , maybe existing features if already registered +-- , maybe some default study features +-- , maybe a course secret +registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) +-- unfinished WIP: must take study features if registred and show as mforced field +registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do + -- secret fields + (msecretRes', msecretView) <- case msecret of + (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing + _ -> return (Nothing,Nothing) + -- study features + (msfRes', msfView) <- case loggedin of + Nothing -> return (Nothing,Nothing) + Just _ -> bimap Just Just <$> case participant of + Just CourseParticipant{courseParticipantField=Just sfid} + -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid) + _other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature + & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid) + -- button de-/register + (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing -registerForm :: Bool -> Maybe Text -> Form Bool -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 "registerBtn" $ 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 @@ -528,7 +558,7 @@ courseToForm (Entity cid Course{..}) = CourseForm } makeCourseForm :: Maybe CourseForm -> Form CourseForm -makeCourseForm template = identForm FIDcourse $ \html -> do +makeCourseForm template = identifyForm FIDcourse $ \html -> do -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring @@ -621,25 +651,53 @@ validateCourse CourseForm{..} = ] ] + -------------------- -- CourseUserTable -type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) -type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) -type UserTableData = DBRow (Entity User, E.Value UTCTime, E.Value (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 @@ -649,49 +707,89 @@ instance HasUser UserTableData where hasUser = _dbrOutput . _1 . _entityVal _userTableRegistration :: Lens' UserTableData UTCTime -_userTableRegistration = _dbrOutput . _2 . _unValue +_userTableRegistration = _dbrOutput . _2 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) -_userTableNote = _dbrOutput . _3 . _unValue +_userTableNote = _dbrOutput . _3 --- default Where-Clause -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 _, _, E.Value 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 = return -- . dbrOutput -- NOT SURE + 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,22 +798,24 @@ getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR tid ssh csh = do (course, numParticipants, participantTable) <- runDB $ do let colChoices = mconcat - [ colUserParticipantLink tid ssh csh + [ colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr + , colUserDegreeShort + , colUserField + , colUserSemester , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration) , colUserComment tid ssh csh ] psValidator = def - Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh + Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - participantTable <- makeCourseUserTable (courseIs cid) colChoices psValidator + participantTable <- makeCourseUserTable cid colChoices psValidator return (course, numParticipants, participantTable) let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do setTitleI headingShort - $(widgetFile "course-participants") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 6363b641a..b9579f26d 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -192,7 +192,7 @@ getImpressumR :: Handler Html getImpressumR = -- do siteLayoutMsg' MsgMenuImpressum $ do setTitleI MsgImpressumHeading - $(widgetFile "impressum") + $(i18nWidgetFile "imprint") -- | Hinweise zu Datenschutz und Aufbewahrungspflichten @@ -200,7 +200,7 @@ getDataProtR :: Handler Html getDataProtR = -- do siteLayoutMsg' MsgMenuDataProt $ do setTitleI MsgDataProtHeading - $(widgetFile "data-protection-de") + $(i18nWidgetFile "data-protection") -- | Allgemeine Informationen @@ -280,8 +280,7 @@ getInfoLecturerR :: Handler Html getInfoLecturerR = siteLayoutMsg' MsgInfoLecturerTitle $ do setTitleI MsgInfoLecturerTitle - -- TODO: Translation. This is simply too much for a simple message and too akwward to cut into bits. Create i18nWidgetFile tool. - $(widgetFile "infoLecturer") + $(i18nWidgetFile "info-lecturer") getAuthPredsR, postAuthPredsR :: Handler Html diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a57e1149c..f615d3899 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -27,7 +27,7 @@ data SettingsForm = SettingsForm } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm -makeSettingForm template = identForm FIDsettings $ \html -> do +makeSettingForm template = identifyForm FIDsettings $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm <$ aformSection MsgFormCosmetics <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here @@ -248,6 +248,8 @@ getProfileDataR = do let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] + lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication + -- Delete Button (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) defaultLayout $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index f6e4fe51c..c2c8136d1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -90,7 +90,7 @@ getFtIdMap sId = do return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds] makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm -makeSheetForm msId template = identForm FIDsheet $ \html -> do +makeSheetForm msId template = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId @@ -780,7 +780,7 @@ postSCorrR = getSCorrR getSCorrR tid ssh csh shn = do Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn - ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton + ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton case res of FormFailure errs -> mapM_ (addMessage Error . toHtml) errs diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index feb44cb9b..6ce62d265 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -49,7 +49,7 @@ import System.FilePath makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail) -makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do +makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do let fileUploadForm = case uploadMode of NoUpload -> pure Nothing diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index ad791a9e6..34ab467ac 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -35,7 +35,7 @@ postMessageR cID = do let mkForm = do - ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard + ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard $ SystemMessage <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom) <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo) @@ -51,7 +51,7 @@ postMessageR cID = do modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do cID' <- encrypt tId - runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard + runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard $ (,) <$> fmap (Entity tId) ( SystemMessageTranslation @@ -64,7 +64,7 @@ postMessageR cID = do let modifyTranss = Map.map (view $ _1._1) modifyTranss' - ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard + ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard $ SystemMessageTranslation <$> pure smId <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing @@ -215,6 +215,7 @@ postMessageListR = do return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id + , dbParamsFormIdent = def } , dbtIdent = "messages" :: Text } @@ -246,7 +247,7 @@ postMessageListR = do FormSuccess (_, _selection) -- prop> null _selection -> addMessageI Error MsgSystemMessageEmptySelection - ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage + ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index d6accb27c..784486f91 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -145,7 +145,7 @@ getTermShowR = do , dbtIdent = "terms" :: Text } defaultLayout $ do - setTitle "Freigeschaltete Semester" + setTitleI MsgTermsHeading $(widgetFile "terms") getTermEditR :: Handler Html diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 02c25257b..1d3e63e9a 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -7,6 +7,13 @@ import Import import qualified Data.Text as T -- import qualified Data.Set (Set) import qualified Data.Set as Set +import Data.CaseInsensitive (CI, original) +-- import qualified Data.CaseInsensitive as CI + +import Language.Haskell.TH (Q, Exp) +-- import Language.Haskell.TH.Datatype + +import Text.Hamlet (shamletFile) import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils @@ -36,9 +43,16 @@ tidFromText = fmap TermKey . maybeRight . termFromText simpleLink :: Widget -> Route UniWorX -> Widget simpleLink lbl url = [whamlet|^{lbl}|] +-- | toWidget-Version of @nameHtml@, for convenience nameWidget :: Text -> Text -> Widget nameWidget displayName surname = toWidget $ nameHtml displayName surname +-- | toWidget-Version of @nameEmailHtml@, for convenience +nameEmailWidget :: CI Text -> Text -> Text -> Widget +nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname + +-- | Show user's displayName, highlighting the surname if possible. +-- Otherwise appends the surname in parenthesis nameHtml :: Text -> Text -> Html nameHtml displayName surname | null surname = toHtml displayName @@ -56,6 +70,21 @@ nameHtml displayName surname |] [] -> error "Data.Text.splitOn returned empty list in violation of specification." +-- | Like nameHtml just show a users displayname with hightlighted surname, +-- but also wrap the name with a mailto-link +nameEmailHtml :: CI Text -> Text -> Text -> Html +nameEmailHtml email displayName surname = + wrapMailto email $ nameHtml displayName surname + +-- | Wrap mailto around given Html using single hamlet-file for consistency +wrapMailto :: CI Text -> Html -> Html +wrapMailto (original -> email) linkText + | null email = linkText + | otherwise = $(shamletFile "templates/widgets/link-email.hamlet") + +-- | Just show an email address in a standard way, for convenience inside hamlet files. +mailtoHtml :: CI Text -> Html +mailtoHtml email = wrapMailto email $ toHtml email -- | Prefix a message with a short cours id, -- eg. for window title bars, etc. @@ -87,3 +116,12 @@ warnTermDays tid times = do forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoftermdays $ warnI MsgDayIsOutOfTerm +-- | Add language dependent template files +-- For large files which are translated as a whole. +-- Argument musst be a directory under templates, +-- which contains a file for each language, +-- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet +i18nWidgetFile :: FilePath -> Q Exp +i18nWidgetFile = + -- TODO write code to distinguish languages here + widgetFile . ( "de") \ No newline at end of file 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/Delete.hs b/src/Handler/Utils/Delete.hs index 400ef2d72..e98d7d98f 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -51,7 +51,7 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1 confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool -confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString +confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString where addDeleteTargets :: Form a -> Form a addDeleteTargets form csrf = do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2a568432e..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 @@ -481,6 +522,30 @@ secretJsonField = Field{..} |] fieldEnctype = UrlEncoded +boolField :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Field m Bool +boolField = Field + { fieldParse = \e _ -> return $ boolParser e + , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") + , fieldEnctype = UrlEncoded + } + where + boolParser [] = Right Nothing + boolParser (x:_) = case x of + "" -> Right Nothing + "none" -> Right Nothing + "yes" -> Right $ Just True + "on" -> Right $ Just True + "no" -> Right $ Just False + "true" -> Right $ Just True + "false" -> Right $ Just False + t -> Left $ SomeMessage $ MsgInvalidBool t + showVal = either $ const False + + + funcForm :: forall k v m. ( Finite k, Ord k @@ -540,42 +605,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs -mforced :: (site ~ HandlerSite m, MonadHandler m) - => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) -mforced Field{..} FieldSettings{..} val = do - tell fieldEnctype - name <- maybe newFormIdent return fsName - theId <- lift $ maybe newIdent return fsId - mr <- getMessageRender - let fsAttrs' = fsAttrs <> [("disabled", "")] - return ( FormSuccess val - , FieldView - { fvLabel = toHtml $ mr fsLabel - , fvTooltip = toHtml <$> fmap mr fsTooltip - , fvId = theId - , fvInput = fieldView theId name fsAttrs' (Right val) False - , fvErrors = Nothing - , fvRequired = False - } - ) - -aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) - => Field m a -> FieldSettings site -> a -> AForm m a -aforced field settings val = formToAForm $ second pure <$> mforced field settings val - -apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) - => Field m a -> FieldSettings site -> Maybe a -> AForm m a --- ^ Pseudo required -apreq f fs mx = formToAForm $ do - mr <- getMessageRender - over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx) - -wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) - => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) -wpreq f fs mx = mFormToWForm $ do - mr <- getMessageRender - over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx) - multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) => Map action (AForm (HandlerT UniWorX IO) a) -> Maybe action @@ -630,5 +659,5 @@ formResultModal res finalDest handler = maybeT_ $ do if | isModal -> sendResponse $ toJSON messages | otherwise -> do - forM_ messages $ \Message{..} -> addMessage messageClass messageContent + forM_ messages $ \Message{..} -> addMessage messageStatus messageContent redirect finalDest 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 68bd0e9a3..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 @@ -65,7 +83,8 @@ userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname emailCell :: IsDBTable m a => CI Text -> DBCell m a -emailCell userEmail = cell $(widgetFile "widgets/link-email") +emailCell email = cell $(widgetFile "widgets/link-email") + where linkText= toWgt email cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) @@ -166,30 +185,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc - --------------------------------- --- Generic Columns --- reuse encourages consistency --- --- if it works out, turn into its own module --- together with filters and sorters - - --- | Does not work, since we have now show Instance for RenderMesage UniWorX msg -colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c) -colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser - -colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser - -colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c) -colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink) - where - -- courseLink :: CryptoUUIDUser -> Route UniWorX - courseLink = CourseR tid ssh csh . CUserR - -colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer - -colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail 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 67e5a3f46..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) @@ -461,6 +459,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where def = DBParamsDB +data DBParamsFormIdent where + DBParamsFormTableIdent :: DBParamsFormIdent + DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent + DBParamsFormNoIdent :: DBParamsFormIdent + +instance Default DBParamsFormIdent where + def = DBParamsFormTableIdent + +unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text +unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toPathPiece dbtIdent +unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x +unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing + instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm { dbParamsFormMethod :: StdMethod @@ -470,6 +481,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc , dbParamsFormAdditional :: Form a , dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype) , dbParamsFormResult :: Lens' x (FormResult a) + , dbParamsFormIdent :: DBParamsFormIdent } type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget) -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype) @@ -492,7 +504,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget) - runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment + runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys + = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) + . dbParamsFormEvaluate + . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) + . dbParamsFormWrap dbtParams + . maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent) + . addPIHiddenField dbtable pi + . addPreviousHiddenField dbtable pKeys + . withFragment dbInvalidateResult DBParamsForm{..} reason result = do reasonTxt <- getMessageRender <*> pure reason @@ -510,6 +530,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La , dbParamsFormAdditional = \_ -> return (pure (), mempty) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s) + , dbParamsFormIdent = def } dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) @@ -605,9 +626,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo - (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi) + (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi) - (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $ + (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $ areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) <* autosubmitButton return (filterRes', pagesizeRes') @@ -629,7 +650,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing | otherwise = (, def) $ runPSValidator dbtable Nothing - psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting + psSorting' = map (\SortingSetting{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting mapM_ (addMessageI Warning) errs @@ -642,9 +663,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> do E.limit l E.offset (psPage * l) - Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps + Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps _other -> return () - Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter + Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v) @@ -846,11 +867,11 @@ instance Ord i => Monoid (DBFormResult i a r) where getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m -formCell :: forall res r i a. (Ord i, Monoid res) - => 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) @@ -873,11 +894,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex -dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res) - => 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 1f1220787..1a6255df4 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -61,6 +61,9 @@ import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) +import System.Random as Import (Random) +import Control.Monad.Random.Class as Import (MonadRandom(..)) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Model.hs b/src/Model.hs index 54acc1b28..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 Utils.Message (MessageClass) +import Text.Blaze (ToMarkup, toMarkup, Markup) +import Utils.Message (MessageStatus) + import Settings.Cluster (ClusterSettingsKey) import Data.Binary (Binary) @@ -41,3 +43,20 @@ deriving instance Binary (Key Term) submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +-- Do these instances belong here? +instance ToMarkup StudyDegree where + toMarkup StudyDegree{..} = toMarkup $ + fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand) + +shortStudyDegree :: StudyDegree -> Markup +shortStudyDegree StudyDegree{..} = toMarkup $ + fromMaybe (tshow studyDegreeKey) studyDegreeShorthand + +instance ToMarkup StudyTerms where + toMarkup StudyTerms{..} = toMarkup $ + fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand) + +shortStudyTerms :: StudyTerms -> Markup +shortStudyTerms StudyTerms{..} = toMarkup $ + fromMaybe (tshow studyTermsKey) studyTermsShorthand 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/Settings.hs b/src/Settings.hs index 81f98eb45..f717ee378 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -39,7 +39,7 @@ import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap -import Utils hiding (MessageClass(..)) +import Utils hiding (MessageStatus(..)) import Control.Lens import Data.Maybe (fromJust) diff --git a/src/Utils.hs b/src/Utils.hs index a523c723b..25142c944 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -24,8 +24,7 @@ import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils import Utils.Lang as Utils -import Control.Lens as Utils (none) - +import Utils.Parameters as Utils import Text.Blaze (Markup, ToMarkup) @@ -33,13 +32,16 @@ import Data.Char (isDigit, isSpace) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Numeric (showFFloat) -import Control.Lens import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map -- import qualified Data.List as List +import Control.Lens +import Control.Lens as Utils (none) + +import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -159,6 +161,11 @@ hasTickmark :: Bool -> Markup hasTickmark True = [shamlet||] hasTickmark False = mempty +isNew :: Bool -> Markup +isNew True = [shamlet||] +isNew False = mempty + + --------------------- -- Text and String -- --------------------- @@ -320,6 +327,17 @@ mergeAttrs = mergeAttrs' `on` sort +---------- +-- Sets -- +---------- + +-- | Intersection of multiple sets. Returns empty set for empty input list +setIntersections :: Ord a => [Set a] -> Set a +setIntersections [] = Set.empty +setIntersections (h:t) = foldl' Set.intersection h t + + + ---------- -- Maps -- ---------- @@ -340,6 +358,17 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList +--------------- +-- Functions -- +--------------- + +-- curryN, uncurryN see Utils.TH + +-- | Just @flip (.)@ for convenient formatting in some cases, +-- Deprecated in favor of Control.Arrow.(>>>) +compose :: (a -> b) -> (b -> c) -> (a -> c) +compose = flip (.) + ----------- -- Maybe -- @@ -473,8 +502,6 @@ throwExceptT :: ( Exception e, MonadThrow m ) => ExceptT e m a -> m a throwExceptT = exceptT throwM return - - ------------ -- Monads -- ------------ @@ -574,32 +601,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) -- GET Parameters -- -------------------- -data GlobalGetParam = GetReferer - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe GlobalGetParam -instance Finite GlobalGetParam -nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1) - -lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result) -lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident) - -hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool -hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) - - -data GlobalPostParam = PostDeleteTarget - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe GlobalPostParam -instance Finite GlobalPostParam -nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1) - -lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result) -lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident) - -hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool -hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) +-- Moved to Utils.Parameters --------------------------------- -- Custom HTTP Request-Headers -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8c53501f8..bf8243b69 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -2,9 +2,11 @@ module Utils.Form where -import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..)) +import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm) import Settings +import Utils.Parameters + -- import Text.Blaze (toMarkup) -- for debugging import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T @@ -18,6 +20,8 @@ import qualified Data.Map.Lazy as Map import qualified Data.Set as Set import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Data.List ((!!)) @@ -194,6 +198,7 @@ addAutosubmit = addAttr "data-autosubmit" "" data FormIdentifier = FIDcourse + | FIDcourseRegister | FIDsheet | FIDsubmission | FIDsettings @@ -209,7 +214,9 @@ data FormIdentifier | FIDSystemMessageAddTranslation | FIDDBTableFilter | FIDDBTablePagesize + | FIDDBTable | FIDDelete + | FIDCourseRegister deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -217,11 +224,32 @@ instance PathPiece FormIdentifier where toPathPiece = showToPathPiece -identForm :: (Monad m, PathPiece ident) - => ident -- ^ Form identification - -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) - -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) -identForm = identifyForm . toPathPiece +identifyForm' :: (Monad m, PathPiece ident, Eq ident) + => Lens' x (FormResult a) + -> ident -- ^ Form identification + -> (Html -> MForm m (x, widget)) + -> (Html -> MForm m (x, widget)) +identifyForm' resLens identVal form fragment = do + -- Create hidden . + let fragment' = + [shamlet| + + #{fragment} + |] + + -- Check if we got its value back. + hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier + + -- Run the form proper (with our hidden ). If the + -- data is missing, then do not provide any params to the + -- form, which will turn its result into FormMissing. Also, + -- doing this avoids having lots of fields with red errors. + let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l)) + | otherwise = id + fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment' + +identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget)) +identifyForm = identifyForm' id {- Hinweise zur Erinnerung: - identForm primär, wenn es mehr als ein Formular pro Handler gibt @@ -512,4 +540,42 @@ prismAForm p outer form = review p <$> form inner where inner = outer >>= preview p +--------------------------------------------- +-- Special variants of @mopt@, @mreq@, ... -- +--------------------------------------------- +mforced :: (site ~ HandlerSite m, MonadHandler m) + => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) +mforced Field{..} FieldSettings{..} val = do + tell fieldEnctype + name <- maybe newFormIdent return fsName + theId <- lift $ maybe newIdent return fsId + mr <- getMessageRender + let fsAttrs' = fsAttrs <> [("disabled", "")] + return ( FormSuccess val + , FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml <$> fmap mr fsTooltip + , fvId = theId + , fvInput = fieldView theId name fsAttrs' (Right val) False + , fvErrors = Nothing + , fvRequired = False + } + ) + +aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> a -> AForm m a +aforced field settings val = formToAForm $ second pure <$> mforced field settings val + +apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> AForm m a +-- ^ Pseudo required +apreq f fs mx = formToAForm $ do + mr <- getMessageRender + over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx) + +wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) +wpreq f fs mx = mFormToWForm $ do + mr <- getMessageRender + over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b8ac05e63..1443b259d 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -80,6 +80,15 @@ makeLenses_ ''SheetType makePrisms ''AuthResult +makeLenses_ ''StudyFeatures + +makeLenses_ ''StudyDegree + +makeLenses_ ''StudyTerms + +makeLenses_ ''StudyTermCandidate + + -- makeClassy_ ''Load diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 7cf7f653f..69ce9e45e 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,6 +1,6 @@ module Utils.Message - ( MessageClass(..) - , UnknownMessageClass(..) + ( MessageStatus(..) + , UnknownMessageStatus(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , Message(..) , messageI, messageIHamlet, messageFile, messageWidget @@ -25,64 +25,64 @@ import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.HTML.SanitizeXSS (sanitizeBalance) -data MessageClass = Error | Warning | Info | Success +data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) -instance Universe MessageClass -instance Finite MessageClass +instance Universe MessageStatus +instance Finite MessageStatus deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece - } ''MessageClass + } ''MessageStatus -nullaryPathPiece ''MessageClass camelToPathPiece -derivePersistField "MessageClass" +nullaryPathPiece ''MessageStatus camelToPathPiece +derivePersistField "MessageStatus" -newtype UnknownMessageClass = UnknownMessageClass Text +newtype UnknownMessageStatus = UnknownMessageStatus Text deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance Exception UnknownMessageClass +instance Exception UnknownMessageStatus data Message = Message - { messageClass :: MessageClass + { messageStatus :: MessageStatus , messageContent :: Html } instance Eq Message where - a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b + a == b = ((==) `on` messageStatus) a b && ((==) `on` renderHtml . messageContent) a b instance Ord Message where - a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b + a `compare` b = (compare `on` messageStatus) a b `mappend` (compare `on` renderHtml . messageContent) a b instance ToJSON Message where toJSON Message{..} = object - [ "class" .= messageClass + [ "status" .= messageStatus , "content" .= renderHtml messageContent ] instance FromJSON Message where parseJSON = withObject "Message" $ \o -> do - messageClass <- o .: "class" + messageStatus <- o .: "status" messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" return Message{..} -addMessage :: MonadHandler m => MessageClass -> Html -> m () +addMessage :: MonadHandler m => MessageStatus -> Html -> m () addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) -addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m () +addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m () addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) -messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message -messageI messageClass msg = do +messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message +messageI messageStatus msg = do messageContent <- toHtml . ($ msg) <$> getMessageRender return Message{..} addMessageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site - ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m () + ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m () addMessageIHamlet mc iHamlet = do mr <- getMessageRender ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) @@ -90,22 +90,22 @@ addMessageIHamlet mc iHamlet = do messageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site - ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message + ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message messageIHamlet mc iHamlet = do mr <- getMessageRender Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) -addMessageFile :: MessageClass -> FilePath -> ExpQ +addMessageFile :: MessageStatus -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] -messageFile :: MessageClass -> FilePath -> ExpQ +messageFile :: MessageStatus -> FilePath -> ExpQ messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|] addMessageWidget :: forall m site. ( MonadHandler m , HandlerSite m ~ site , Yesod site - ) => MessageClass -> WidgetT site IO () -> m () + ) => MessageStatus -> WidgetT site IO () -> m () -- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead` addMessageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt @@ -115,7 +115,7 @@ messageWidget :: forall m site. ( MonadHandler m , HandlerSite m ~ site , Yesod site - ) => MessageClass -> WidgetT site IO () -> m Message + ) => MessageStatus -> WidgetT site IO () -> m Message messageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs new file mode 100644 index 000000000..81b0c210a --- /dev/null +++ b/src/Utils/Parameters.hs @@ -0,0 +1,78 @@ +module Utils.Parameters + ( GlobalGetParam(..) + , lookupGlobalGetParam, hasGlobalGetParam + , lookupGlobalGetParamForm, hasGlobalGetParamForm + , globalGetParamField + , GlobalPostParam(..) + , lookupGlobalPostParam, hasGlobalPostParam + , lookupGlobalPostParamForm, hasGlobalPostParamForm + , globalPostParamField + ) where + +import ClassyPrelude.Yesod + +import Utils.PathPiece + +import qualified Data.Map as Map + +import Data.Universe + +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +data GlobalGetParam = GetReferer + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe GlobalGetParam +instance Finite GlobalGetParam +nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1) + +lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result) +lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident) + +hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool +hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) + + +lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result) +lookupGlobalGetParamForm ident = runMaybeT $ do + ps <- MaybeT askParams + MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece + +hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool +hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams + +globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a) +globalGetParamField ident Field{fieldParse} = runMaybeT $ do + ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams + fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles + MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs) + +data GlobalPostParam = PostFormIdentifier + | PostDeleteTarget + | PostMassInputShape + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe GlobalPostParam +instance Finite GlobalPostParam +nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1) + +lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result) +lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident) + +hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool +hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) + +lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result) +lookupGlobalPostParamForm ident = runMaybeT $ do + ps <- MaybeT askParams + MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece + +hasGlobalPostParamForm :: Monad m => GlobalPostParam -> MForm m Bool +hasGlobalPostParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams + +globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a) +globalPostParamField ident Field{fieldParse} = runMaybeT $ do + ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams + fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles + MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs) 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/stack.nix b/stack.nix index 7a8a0dcbf..e986ba349 100644 --- a/stack.nix +++ b/stack.nix @@ -1,8 +1,14 @@ -{ ghc, nixpkgs ? (import {}) }: +{ ghc, nixpkgs ? import }: let - inherit (nixpkgs) haskell pkgs; - haskellPackages = if ghc.version == pkgs.haskellPackages.ghc.version then pkgs.haskellPackages else pkgs.haskell.packages."ghc${builtins.replaceStrings ["."] [""] ghc.version}"; + snapshot = "lts-10.5"; + stackage = import (fetchTarball { + url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz"; + sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz"; + }); + inherit (nixpkgs { overlays = [ stackage."${snapshot}" ]; }) haskell pkgs; + + haskellPackages = pkgs.haskell.packages."${snapshot}"; in haskell.lib.buildStackProject { inherit ghc; name = "stackenv"; diff --git a/stack.yaml b/stack.yaml index c4f2d4dba..94be126d8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,10 @@ packages: git: https://github.com/pngwjpgh/encoding.git commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 extra-dep: true + - location: + git: https://github.com/pngwjpgh/memcached-binary.git + commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad + extra-dep: true extra-deps: - colonnade-1.2.0 @@ -45,8 +49,4 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 - - memcached-binary-0.2.0 - -allow-newer: true - resolver: lts-10.5 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/static/css/utils/asidenav.scss b/static/css/utils/asidenav.scss index 51fe73163..1ac580d58 100644 --- a/static/css/utils/asidenav.scss +++ b/static/css/utils/asidenav.scss @@ -57,7 +57,7 @@ padding-left: 10px; &.js-show-hide__toggle::before { - top: 25px; + z-index: 1; } } } @@ -103,7 +103,6 @@ &::before { left: auto; right: 20px; - top: 30px; color: var(--color-font); } } @@ -314,6 +313,10 @@ word-break: break-all; background-color: var(--color-dark); color: var(--color-lightwhite); + + &:hover { + background-color: var(--color-dark); + } } .asidenav__link-shorthand { diff --git a/static/css/utils/asyncForm.scss b/static/css/utils/asyncForm.scss index cd4fe3159..a0f9956dd 100644 --- a/static/css/utils/asyncForm.scss +++ b/static/css/utils/asyncForm.scss @@ -1,9 +1,78 @@ .async-form-response { margin: 20px 0; + position: relative; + width: 100%; + font-size: 18px; + text-align: center; + padding-top: 60px; +} + +.async-form-response::before, +.async-form-response::after { + position: absolute; + top: 0px; + left: 50%; + display: block; +} + +.async-form-response--success::before { + content: ''; + width: 17px; + height: 28px; + border: solid #069e04; + border-width: 0 5px 5px 0; + transform: translateX(-50%) rotate(45deg); +} + +.async-form-response--info::before { + content: ''; + width: 5px; + height: 30px; + top: 10px; + background-color: #777; + transform: translateX(-50%); +} +.async-form-response--info::after { + content: ''; + width: 5px; + height: 5px; + background-color: #777; + transform: translateX(-50%); +} + +.async-form-response--warning::before { + content: ''; + width: 5px; + height: 30px; + background-color: rgb(255, 187, 0); + transform: translateX(-50%); +} +.async-form-response--warning::after { + content: ''; + width: 5px; + height: 5px; + top: 35px; + background-color: rgb(255, 187, 0); + transform: translateX(-50%); +} + +.async-form-response--error::before { + content: ''; + width: 5px; + height: 40px; + background-color: #940d0d; + transform: translateX(-50%) rotate(-45deg); +} +.async-form-response--error::after { + content: ''; + width: 5px; + height: 40px; + background-color: #940d0d; + transform: translateX(-50%) rotate(45deg); } .async-form-loading { opacity: 0.1; - transition: opacity 800ms ease-in-out; + transition: opacity 800ms ease-out; pointer-events: none; } diff --git a/static/css/utils/asyncTable.scss b/static/css/utils/asyncTable.scss new file mode 100644 index 000000000..9766daa84 --- /dev/null +++ b/static/css/utils/asyncTable.scss @@ -0,0 +1,5 @@ +.async-table--loading { + opacity: 0.7; + pointer-events: none; + transition: opacity 400ms ease-out; +} diff --git a/static/css/utils/asyncTableFilter.scss b/static/css/utils/asyncTableFilter.scss new file mode 100644 index 000000000..794240f3f --- /dev/null +++ b/static/css/utils/asyncTableFilter.scss @@ -0,0 +1,5 @@ +.async-table-filter--loading { + opacity: 0.7; + pointer-events: none; + transition: opacity 400ms ease-out; +} diff --git a/static/css/utils/checkbox.scss b/static/css/utils/checkbox.scss new file mode 100644 index 000000000..4cab1568e --- /dev/null +++ b/static/css/utils/checkbox.scss @@ -0,0 +1,74 @@ + +/* CUSTOM CHECKBOXES */ +/* Completely replaces legacy checkbox */ +.checkbox { + position: relative; + display: inline-block; + + [type="checkbox"] { + position: fixed; + top: -1px; + left: -1px; + width: 1px; + height: 1px; + overflow: hidden; + } + + label { + display: block; + height: 24px; + width: 24px; + background-color: #f3f3f3; + box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05); + border: 2px solid var(--color-primary); + border-radius: 4px; + color: white; + cursor: pointer; + } + + label::before, + label::after { + position: absolute; + display: block; + top: 12px; + left: 8px; + height: 2px; + width: 8px; + background-color: var(--color-font); + } + + :checked + label { + background-color: var(--color-primary); + } + + [type="checkbox"]:focus + label { + border-color: #3273dc; + box-shadow: 0 0 0 0.125em rgba(50,115,220,.25); + outline: 0; + } + + :checked + label::before, + :checked + label::after { + content: ''; + } + + :checked + label::before { + background-color: white; + transform: rotate(45deg); + left: 4px; + } + + :checked + label::after { + background-color: white; + transform: rotate(-45deg); + top: 11px; + width: 13px; + } + + [disabled] + label { + pointer-events: none; + border: none; + opacity: 0.6; + filter: grayscale(1); + } +} diff --git a/static/css/utils/inputs.scss b/static/css/utils/inputs.scss index f30155892..6bf5286e3 100644 --- a/static/css/utils/inputs.scss +++ b/static/css/utils/inputs.scss @@ -95,7 +95,6 @@ select { width: 100%; max-width: 600px; - -webkit-appearance: none; align-items: center; border: 1px solid transparent; border-radius: 4px; @@ -162,6 +161,11 @@ textarea { } /* OPTIONS */ + +select { + -webkit-appearance: menulist; +} + select, option { font-size: 1rem; @@ -171,7 +175,8 @@ option { border-radius: 2px; outline: 0; color: #363636; - min-width: 200px; + min-width: 250px; + width: auto; background-color: #f3f3f3; box-shadow: inset 0 1px 2px 1px rgba(50,50,50,.05); } @@ -183,130 +188,6 @@ option { } } -/* CUSTOM LEGACY CHECKBOX AND RADIO BOXES */ -input[type="checkbox"] { - position: relative; - height: 20px; - width: 20px; - -webkit-appearance: none; - appearance: none; - cursor: pointer; -} -input[type="checkbox"]::before { - content: ''; - position: absolute; - width: 20px; - height: 20px; - background-color: var(--color-lighter); - display: flex; - align-items: center; - justify-content: center; - border-radius: 2px; -} -input[type="checkbox"]:checked::before { - background-color: var(--color-light); -} -input[type="checkbox"]:checked::after { - content: '✓'; - position: absolute; - width: 20px; - height: 20px; - display: flex; - align-items: center; - justify-content: center; - color: white; - font-size: 20px; -} - -/* CUSTOM CHECKBOXES AND RADIO BOXES */ -/* Completely replaces legacy checkbox and radiobox */ -.checkbox, -.radio { - position: relative; - display: inline-block; - - [type="checkbox"], - [type="radio"] { - position: fixed; - top: -1px; - left: -1px; - width: 1px; - height: 1px; - overflow: hidden; - } - - label { - display: block; - height: 24px; - width: 24px; - background-color: #f3f3f3; - box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05); - border: 2px solid var(--color-primary); - border-radius: 4px; - color: white; - cursor: pointer; - } - - label::before, - label::after { - position: absolute; - display: block; - top: 12px; - left: 8px; - height: 2px; - width: 8px; - background-color: var(--color-font); - } - - :checked + label { - background-color: var(--color-primary); - } - - [type="checkbox"]:focus + label, - [type="radio"]:focus + label { - border-color: #3273dc; - box-shadow: 0 0 0 0.125em rgba(50,115,220,.25); - outline: 0; - } - - :checked + label::before, - :checked + label::after { - content: ''; - } - - :checked + label::before { - background-color: white; - transform: rotate(45deg); - left: 4px; - } - - :checked + label::after { - background-color: white; - transform: rotate(-45deg); - top: 11px; - width: 13px; - } - - [disabled] + label { - pointer-events: none; - border: none; - opacity: 0.6; - filter: grayscale(1); - } -} - -.radio::before { - content: ''; - position: absolute; - top: 2px; - left: 2px; - right: 2px; - bottom: 2px; - border-radius: 4px; - border: 2px solid white; - z-index: -1; -} - /* CUSTOM FILE INPUT */ .file-input__label { cursor: pointer; diff --git a/static/css/utils/modal.scss b/static/css/utils/modal.scss index 5cac989a3..2f5d0e168 100644 --- a/static/css/utils/modal.scss +++ b/static/css/utils/modal.scss @@ -3,7 +3,7 @@ left: 50%; top: 50%; transform: translate(-50%, -50%) scale(0.8, 0.8); - display: block; + display: flex; background-color: rgba(255, 255, 255, 1); min-width: 60vw; min-height: 100px; @@ -26,10 +26,6 @@ z-index: 200; transform: translate(-50%, -50%) scale(1, 1); } - - .modal__content { - margin: 20px 0; - } } @media (max-width: 1024px) { @@ -96,3 +92,8 @@ color: white; } } + +.modal__content { + margin: 20px 0; + width: 100%; +} diff --git a/static/css/utils/radio.scss b/static/css/utils/radio.scss new file mode 100644 index 000000000..a832de842 --- /dev/null +++ b/static/css/utils/radio.scss @@ -0,0 +1,76 @@ +/* CUSTOM RADIO BOXES */ +/* Completely replaces native radiobox */ + +.radio-group { + display: flex; +} + +.radio-group__option { + min-width: 30px; +} + +.radio { + position: relative; + display: inline-block; + + [type="radio"] { + position: fixed; + top: -1px; + left: -1px; + width: 1px; + height: 1px; + overflow: hidden; + } + + label { + display: block; + height: 34px; + min-width: 42px; + line-height: 34px; + text-align: center; + padding: 0 13px; + background-color: #f3f3f3; + box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05); + color: var(--color-font); + cursor: pointer; + } + + :checked + label { + background-color: var(--color-primary); + color: var(--color-lightwhite); + box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15); + } + + :focus + label { + border-color: #3273dc; + box-shadow: 0 0 0.125em 0 rgba(50,115,220,0.8); + outline: 0; + } + + [disabled] + label { + pointer-events: none; + border: none; + opacity: 0.6; + filter: grayscale(1); + } +} + +.radio:first-child { + label { + border-top-left-radius: 4px; + border-bottom-left-radius: 4px; + } +} + +.radio:last-child { + label { + border-top-right-radius: 4px; + border-bottom-right-radius: 4px; + } +} + +@media (max-width: 768px) { + .radio + .radio { + margin-left: 10px; + } +} diff --git a/static/css/utils/showHide.scss b/static/css/utils/showHide.scss index 64dfe367c..ab82286b8 100644 --- a/static/css/utils/showHide.scss +++ b/static/css/utils/showHide.scss @@ -1,22 +1,30 @@ +$show-hide-toggle-size: 6px; + .js-show-hide__toggle { + position: relative; cursor: pointer; + padding: 3px 7px; + + &:hover { + background-color: var(--color-grey-lighter); + cursor: pointer; + } } .js-show-hide__toggle::before { content: ''; position: absolute; - width: 0; - height: 0; - left: -28px; - top: 6px; + width: $show-hide-toggle-size; + height: $show-hide-toggle-size; + left: -15px; + top: 12px - $show-hide-toggle-size / 2; color: var(--color-primary); - border-right: 8px solid transparent; - border-top: 8px solid transparent; - border-left: 8px solid transparent; - border-bottom: 8px solid currentColor; + border-right: 2px solid currentColor; + border-top: 2px solid currentColor; transition: transform .2s ease; - transform-origin: 8px 12px; + transform-origin: ($show-hide-toggle-size / 2); + transform: translateY($show-hide-toggle-size) rotate(-45deg); } .js-show-hide__target { @@ -26,7 +34,7 @@ .js-show-hide--collapsed { .js-show-hide__toggle::before { - transform: rotate(180deg); + transform: translateY($show-hide-toggle-size / 3) rotate(135deg); } .js-show-hide__target { diff --git a/static/js/utils/alerts.js b/static/js/utils/alerts.js index d52a47376..b854495a0 100644 --- a/static/js/utils/alerts.js +++ b/static/js/utils/alerts.js @@ -87,5 +87,10 @@ initToggler(); alertElements.forEach(initAlert); + + return { + scope: alertsEl, + destroy: function() {}, + }; }; })(); diff --git a/static/js/utils/asidenav.js b/static/js/utils/asidenav.js index 154232109..bb95f6455 100644 --- a/static/js/utils/asidenav.js +++ b/static/js/utils/asidenav.js @@ -55,5 +55,10 @@ initFavoritesButton(); initAsidenavSubmenus(); + + return { + scope: asideEl, + destroy: function() {}, + }; }; })(); diff --git a/static/js/utils/asyncForm.js b/static/js/utils/asyncForm.js index 7917012a9..aa57ed2a0 100644 --- a/static/js/utils/asyncForm.js +++ b/static/js/utils/asyncForm.js @@ -6,9 +6,12 @@ var ASYNC_FORM_RESPONSE_CLASS = 'async-form-response'; var ASYNC_FORM_LOADING_CLASS = 'async-form-loading'; var ASYNC_FORM_MIN_DELAY = 600; + var DEFAULT_FAILURE_MESSAGE = 'The response we received from the server did not match what we expected. Please let us know this happened via the help widget in the top navigation.'; window.utils.asyncForm = function(formElement, options) { + options = options || {}; + var lastRequestTimestamp = 0; function setup() { @@ -16,19 +19,27 @@ } function processResponse(response) { - var responseElement = document.createElement('div'); - responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS); - responseElement.innerHTML = response.content; + var responseElement = makeResponseElement(response.content, response.status); var parentElement = formElement.parentElement; // make sure there is a delay between click and response var delay = Math.max(0, ASYNC_FORM_MIN_DELAY + lastRequestTimestamp - Date.now()); + setTimeout(function() { parentElement.insertBefore(responseElement, formElement); formElement.remove(); }, delay); } + function makeResponseElement(content, status) { + var responseElement = document.createElement('div'); + status = status || 'info'; + responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS); + responseElement.classList.add(ASYNC_FORM_RESPONSE_CLASS + '--' + status); + responseElement.innerHTML = content; + return responseElement; + } + function submitHandler(event) { event.preventDefault(); @@ -47,14 +58,29 @@ window.utils.httpClient.post(url, headers, body) .then(function(response) { - return response.json(); + if (response.headers.get("content-type").indexOf("application/json") !== -1) {// checking response header + return response.json(); + } else { + throw new TypeError('Unexpected Content-Type. Expected Content-Type: "application/json". Requested URL:' + url + '"'); + } }).then(function(response) { - processResponse(response[0]) + processResponse(response[0]); }).catch(function(error) { - console.error('could not fetch or process response from ' + url, { error }); + var failureMessage = DEFAULT_FAILURE_MESSAGE; + if (options.i18n && options.i18n.asyncFormFailure) { + failureMessage = options.i18n.asyncFormFailure; + } + processResponse({ content: failureMessage }); + + formElement.classList.remove(ASYNC_FORM_LOADING_CLASS); }); } setup(); + + return { + scope: formElement, + destroy: function() {}, + }; }; })(); diff --git a/static/js/utils/asyncTable.js b/static/js/utils/asyncTable.js index a7f46a134..5e8e371e9 100644 --- a/static/js/utils/asyncTable.js +++ b/static/js/utils/asyncTable.js @@ -5,6 +5,10 @@ var HEADER_HEIGHT = 80; var RESET_OPTIONS = [ 'scrollTo' ]; + var TABLE_FILTER_FORM_CLASS = 'table-filter-form'; + var ASYNC_TABLE_CONTENT_CHANGED_CLASS = 'async-table--changed'; + var ASYNC_TABLE_LOADING_CLASS = 'async-table--loading'; + var JS_INITIALIZED_CLASS = 'js-async-table-initialized'; window.utils.asyncTable = function(wrapper, options) { @@ -17,6 +21,8 @@ var pagesizeForm; var scrollTable; + var utilInstances = []; + function init() { var table = wrapper.querySelector('#' + tableIdent); @@ -42,17 +48,30 @@ // pagesize form pagesizeForm = wrapper.querySelector('#' + tableIdent + '-pagesize-form'); + // check all + utilInstances.push(window.utils.setup('checkAll', wrapper)); + + // showhide + utilInstances.push(window.utils.setup('showHide', wrapper)); + + // filter + var filterForm = wrapper.querySelector('.' + TABLE_FILTER_FORM_CLASS); + if (filterForm) { + options.updateTableFrom = updateTableFrom; + utilInstances.push(window.utils.setup('asyncTableFilter', filterForm, options)); + } + // take options into account - if (options && options.scrollTo) { + if (options.scrollTo) { window.scrollTo(options.scrollTo); } - if (options && options.horizPos && scrollTable) { + if (options.horizPos && scrollTable) { scrollTable.scrollLeft = options.horizPos; } setupListeners(); - wrapper.classList.add('js-initialized'); + wrapper.classList.add(JS_INITIALIZED_CLASS); } function setupListeners() { @@ -117,32 +136,22 @@ } function changePagesizeHandler(event) { - var currentTableUrl = options.currentUrl || window.location.href; - var url = getUrlWithUpdatedPagesize(currentTableUrl, event.target.value); - url = new URL(getUrlWithResetPagenumber(url)); + var pagesizeParamKey = tableIdent + '-pagesize'; + var pageParamKey = tableIdent + '-page'; + var url = new URL(options.currentUrl || window.location.href); + url.searchParams.set(pagesizeParamKey, event.target.value); + url.searchParams.set(pageParamKey, 0); updateTableFrom(url); } - function getUrlWithUpdatedPagesize(url, pagesize) { - if (url.indexOf('pagesize') >= 0) { - return url.replace(/pagesize=(\d+|all)/, 'pagesize=' + pagesize); - } else if (url.indexOf('?') >= 0) { - return url += '&' + tableIdent + '-pagesize=' + pagesize; - } - - return url += '?' + tableIdent + '-pagesize=' + pagesize; - } - - function getUrlWithResetPagenumber(url) { - return url.replace(/-page=\d+/, '-page=0'); - } - // fetches new sorted table from url with params and replaces contents of current table - function updateTableFrom(url, tableOptions) { + function updateTableFrom(url, tableOptions, callback) { if (!window.utils.httpClient) { throw new Error('httpClient not found!'); } + wrapper.classList.add(ASYNC_TABLE_LOADING_CLASS); + tableOptions = tableOptions || {}; var headers = { 'Accept': 'text/html', @@ -157,6 +166,11 @@ tableOptions.currentUrl = url.href; removeListeners(); updateWrapperContents(data, tableOptions); + if (callback && typeof callback === 'function') { + callback(wrapper); + } + + wrapper.classList.remove(ASYNC_TABLE_LOADING_CLASS); }).catch(function(err) { console.error(err); }); @@ -165,11 +179,11 @@ function updateWrapperContents(newHtml, tableOptions) { tableOptions = tableOptions || {}; wrapper.innerHTML = newHtml; - wrapper.classList.remove("js-initialized"); + wrapper.classList.remove(JS_INITIALIZED_CLASS); + wrapper.classList.add(ASYNC_TABLE_CONTENT_CHANGED_CLASS); + + destroyUtils(); - // setup the wrapper and its components to behave async again - window.utils.teardown('asyncTable'); - window.utils.teardown('form'); // merge global options and table specific options var resetOptions = {}; Object.keys(options) @@ -195,13 +209,26 @@ window.utils.setup('asyncTable', wrapper, combinedOptions); Array.from(wrapper.querySelectorAll('form')).forEach(function(form) { - window.utils.setup('form', form); + utilInstances.push(window.utils.setup('form', form)); }); Array.from(wrapper.querySelectorAll('.modal')).forEach(function(modal) { - window.utils.setup('modal', modal); + utilInstances.push(window.utils.setup('modal', modal)); + }); + } + + function destroyUtils() { + utilInstances.filter(function(utilInstance) { + return !!utilInstance; + }).forEach(function(utilInstance) { + utilInstance.destroy(); }); } init(); + + return { + scope: wrapper, + destroy: destroyUtils, + }; }; })(); diff --git a/static/js/utils/asyncTableFilter.js b/static/js/utils/asyncTableFilter.js new file mode 100644 index 000000000..98d9cda75 --- /dev/null +++ b/static/js/utils/asyncTableFilter.js @@ -0,0 +1,166 @@ +(function () { + 'use strict'; + + window.utils = window.utils || {}; + + var ASYNC_TABLE_FILTER_LOADING_CLASS = 'async-table-filter--loading'; + var JS_INITIALIZED_CLASS = 'js-async-table-filter-initialized'; + var INPUT_DEBOUNCE = 600; + + // debounce function, taken from Underscore.js + function debounce(func, wait, immediate) { + var timeout; + return function() { + var context = this, args = arguments; + var later = function() { + timeout = null; + if (!immediate) func.apply(context, args); + }; + var callNow = immediate && !timeout; + clearTimeout(timeout); + timeout = setTimeout(later, wait); + if (callNow) func.apply(context, args); + }; + }; + + window.utils.asyncTableFilter = function(formElement, options) { + if (!options || !options.updateTableFrom) { + return false; + } + + if (formElement.matches('.' + JS_INITIALIZED_CLASS)) { + return false; + } + options = options || {}; + var tableIdent = options.dbtIdent; + + var formId = formElement.querySelector('[name="_formid"]').value; + var inputs = { + search: [], + input: [], + change: [], + select: [], + } + + function setup() { + gatherInputs(); + addEventListeners(); + } + + function gatherInputs() { + Array.from(formElement.querySelectorAll('input[type="search"]')).forEach(function(input) { + inputs.search.push(input); + }); + + Array.from(formElement.querySelectorAll('input[type="text"]')).forEach(function(input) { + inputs.input.push(input); + }); + + Array.from(formElement.querySelectorAll('input:not([type="text"]):not([type="search"])')).forEach(function(input) { + inputs.change.push(input); + }); + + Array.from(formElement.querySelectorAll('select')).forEach(function(input) { + inputs.select.push(input); + }); + } + + function addEventListeners() { + inputs.search.forEach(function(input) { + var debouncedInput = debounce(function() { + if (input.value.length === 0 || input.value.length > 2) { + updateTable(); + } + }, INPUT_DEBOUNCE); + input.addEventListener('input', debouncedInput); + }); + + inputs.input.forEach(function(input) { + var debouncedInput = debounce(function() { + if (input.value.length === 0 || input.value.length > 2) { + updateTable(); + } + }, INPUT_DEBOUNCE); + input.addEventListener('input', debouncedInput); + }); + + inputs.change.forEach(function(input) { + input.addEventListener('change', function() { + updateTable(); + }); + }); + + inputs.select.forEach(function(input) { + input.addEventListener('change', function() { + updateTable(); + }); + }); + + formElement.addEventListener('submit', function(event) { + event.preventDefault(); + updateTable(); + }); + } + + function updateTable() { + var url = serializeFormToURL(); + var callback = null; + + formElement.classList.add(ASYNC_TABLE_FILTER_LOADING_CLASS); + + var focusedSearch = inputs.search.reduce(function(acc, input) { + return acc || (input.matches(':focus') && input); + }, null); + // focus search input + if (focusedSearch) { + var selectionStart = focusedSearch.selectionStart; + callback = function(wrapper) { + var search = wrapper.querySelector('input[type="search"]'); + if (search) { + search.focus(); + search.selectionStart = selectionStart; + } + }; + } + options.updateTableFrom(url, options, callback); + } + + function serializeFormToURL() { + var url = new URL(options.currentUrl || window.location.href); + url.searchParams.set('_formid', formId); + url.searchParams.set('_hasdata', 'true'); + url.searchParams.set(tableIdent + '-page', '0'); + + inputs.search.forEach(function(input) { + url.searchParams.set(input.name, input.value); + }); + + inputs.input.forEach(function(input) { + url.searchParams.set(input.name, input.value); + }); + + inputs.change.forEach(function(input) { + if (input.checked) { + url.searchParams.set(input.name, input.value); + } + }); + + inputs.select.forEach(function(select) { + var options = Array.from(select.querySelectorAll('option')); + var selected = options.find(function(option) { return option.selected }); + if (selected) { + url.searchParams.set(select.name, selected.value); + } + }); + + return url; + } + + setup(); + + return { + scope: formElement, + destroy: function() {}, + }; + } +})(); diff --git a/static/js/utils/checkAll.js b/static/js/utils/checkAll.js index 5decca2de..b37a89454 100644 --- a/static/js/utils/checkAll.js +++ b/static/js/utils/checkAll.js @@ -3,6 +3,7 @@ window.utils = window.utils || {}; + var ASYNC_TABLE_CONTENT_CHANGED_CLASS = 'async-table--changed'; var JS_INITIALIZED_CLASS = 'js-check-all-initialized'; var CHECKBOX_SELECTOR = '[type="checkbox"]'; @@ -12,7 +13,7 @@ window.utils.checkAll = function(wrapper, options) { - if (!wrapper || wrapper.classList.contains(JS_INITIALIZED_CLASS)) { + if ((!wrapper || wrapper.classList.contains(JS_INITIALIZED_CLASS)) && !wrapper.classList.contains(ASYNC_TABLE_CONTENT_CHANGED_CLASS)) { return false; } options = options || {}; @@ -21,6 +22,8 @@ var checkboxColumn = []; var checkAllCheckbox = null; + var utilInstances = []; + function init() { columns = gatherColumns(wrapper); @@ -79,7 +82,7 @@ checkAllCheckbox.setAttribute('id', getCheckboxId()); th.innerHTML = ''; th.insertBefore(checkAllCheckbox, null); - window.utils.setup('checkboxRadio', checkAllCheckbox); + utilInstances.push(window.utils.setup('checkbox', checkAllCheckbox)); checkAllCheckbox.addEventListener('input', onCheckAllCheckboxInput); setupCheckboxListeners(); @@ -112,6 +115,17 @@ }); } + function destroy() { + utilInstances.forEach(function(util) { + util.destroy(); + }); + } + init(); + + return { + scope: wrapper, + destroy: destroy, + }; }; })(); diff --git a/static/js/utils/form.js b/static/js/utils/form.js index 1e0db4c20..e45fd56c0 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -25,36 +25,50 @@ return false; } + var utilInstances = []; + // reactive buttons - var submitBtn = form.querySelector(SUBMIT_BUTTON_SELECTOR); - if (submitBtn) { - window.utils.setup('reactiveButton', form, { button: submitBtn }); - } + utilInstances.push(window.utils.setup('reactiveButton', form)); // conditonal fieldsets var fieldSets = Array.from(form.querySelectorAll('fieldset[data-conditional-id][data-conditional-value]')); - window.utils.setup('interactiveFieldset', form, { fieldSets }); + utilInstances.push(window.utils.setup('interactiveFieldset', form, { fieldSets })); // hide autoSubmit submit button - window.utils.setup('autoSubmit', form, options); + utilInstances.push(window.utils.setup('autoSubmit', form, options)); // async form if (AJAX_SUBMIT_FLAG in form.dataset) { - window.utils.setup('asyncForm', form, options); + utilInstances.push(window.utils.setup('asyncForm', form, options)); } + // inputs + utilInstances.push(window.utils.setup('inputs', form, options)); + form.classList.add(JS_INITIALIZED); + + function destroyUtils() { + utilInstances.filter(function(utilInstance) { + return !!utilInstance; + }).forEach(function(utilInstance) { + utilInstance.destroy(); + }); + } + + return { + scope: form, + destroy: destroyUtils, + }; }; // registers input-listener for each element in (array) and // enables