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/clean.sh b/clean.sh new file mode 100755 index 000000000..2c9c71212 --- /dev/null +++ b/clean.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash + +case $1 in + "") + exec -- stack clean + ;; + *) + target=".stack-work-${1}" + if [[ ! -d "${target}" ]]; then + printf "%s does not exist or is no directory\n" "${target}" >&2 + exit 1 + fi + if [[ -e .stack-work-clean ]]; then + printf ".stack-work-clean exists\n" >&2 + exit 1 + fi + + move-back() { + mv -v .stack-work "${target}" + [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work + } + + mv -v .stack-work .stack-work-clean + mv -v "${target}" .stack-work + trap move-back EXIT + + stack clean + ;; +esac 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 08f096088..2297642d8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -53,6 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet +CourseStudyFeature: Assoziiertes Hauptfach +CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt. @@ -69,8 +71,8 @@ CourseNewHeading: Neuen Kurs anlegen CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren CourseEditTitle: Kurs editieren/anlegen CourseMembers: Teilnehmer -CourseMembersCount num@Int64: #{display num} -CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} +CourseMembersCount n@Int: #{display n} +CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max} CourseName: Name CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet @@ -87,6 +89,7 @@ CourseRegisterToTip: Anmeldung darf auch unbegrenzt offen bleiben CourseDeregisterUntilTip: Abmeldung darf auch unbegrenzt erlaubt bleiben CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseFilterNone: Egal CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? CourseDeleted: Kurs gelöscht CourseUserNote: Notiz @@ -252,8 +255,10 @@ Theme: Oberflächen Design Favoriten: Anzahl gespeicherter Favoriten Plugin: Plugin Ident: Identifikation +LastLogin: Letzter Login Settings: Individuelle Benutzereinstellungen SettingsUpdate: Einstellungen wurden gespeichert. +Never: Nie MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) @@ -340,6 +345,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter +AdminHeading: Administration AdminUserHeading: Benutzeradministration AccessRightsFor: Berechtigungen für AdminFor: Administrator @@ -401,8 +407,28 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. +AdminFeaturesHeading: Studiengänge +StudyFeatureInference: Studiengangschlüssel-Inferenz +StudyFeatureAge: Fachsemester +StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach FieldSecondary: Nebenfach +NoPrimaryStudyField: (kein Hauptfach registriert) + +DegreeKey: Schlüssel Abschluss +DegreeName: Abschluss +DegreeShort: Abschlusskürzel +StudyTermsKey: Schlüssel Studiengang +StudyTermsName: Studiengang +StudyTermsShort: Studiengangkürzel +StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert +StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert +StudyCandidateIncidence: Anmeldevorgang +AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt +RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt +CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert +NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert +StudyTermIsNew: Neu MailTestFormEmail: Email-Addresse MailTestFormLanguages: Spracheinstellungen @@ -654,3 +680,6 @@ DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde + +MassInputAddDimension: Hinzufügen +MassInputDeleteCell: Entfernen 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 f93b954d4..80e5ff43c 100644 --- a/models/users +++ b/models/users @@ -1,44 +1,68 @@ --- Some comments needes -User json - ident (CI Text) - authentication AuthenticationMode - matrikelnummer Text Maybe - email (CI Text) - displayName Text - surname Text -- always use: nameWidget displayName surname - maxFavourites Int default=12 - theme Theme default='Default' - dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" - dateFormat DateTimeFormat "default='%d.%m.%Y'" - timeFormat DateTimeFormat "default='%R'" - downloadFiles Bool default=false - mailLanguages MailLanguages default='[]' - notificationSettings NotificationSettings - UniqueAuthentication ident - UniqueEmail email - deriving Show Eq Generic -UserAdmin +-- The files in /models determine the database scheme. +-- The organisational split into several files has no operational effects. +-- White-space and case matters: Each SQL table is named in 1st column of this file +-- Indendent lower-case lines describe the SQL-columns of the table with name, type and options +-- Nullable columns have "Maybe" written after their type +-- Option "default=xyz" is only used for database migrations due to changes in the SQL-schema, also see Model.Migration +-- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns. +-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname +-- +User json -- Each Uni2work user has a corresponding row in this table; created upon first login. + ident (CI Text) -- Case-insensitive user-identifier + authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) + lastAuthentication UTCTime Maybe -- last login date + matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) + email (CI Text) -- Case-insensitive eMail address + displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) + surname Text -- Display user names always through 'nameWidget displayName surname' + maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined + theme Theme default='Default' -- Color-theme of the frontend; user-defined + dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined + dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined + timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined + downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) + mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined + notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined + UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table + UniqueEmail email -- Column 'email' can be used as a row-key in this table + deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory +UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user user UserId school SchoolId - UniqueUserAdmin user school -UserLecturer + UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows +UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user user UserId school SchoolId - UniqueSchoolLecturer user school -StudyFeatures -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester + UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows +StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login user UserId - degree StudyDegreeId - field StudyTermsId - type StudyFieldType + degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. + field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. + type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int - -- UniqueUserSubject user degree field -- There exists a counterexample + updated UTCTime default='NOW()' -- last update from LDAP + valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) + UniqueStudyFeatures user degree field type semester + -- UniqueUserSubject ubuser degree field -- There exists a counterexample StudyDegree -- Studienabschluss - key Int - shorthand Text Maybe - name Text Maybe - Primary key + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } + deriving Show StudyTerms -- Studiengang - key Int - shorthand Text Maybe - name Text Maybe - Primary key + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } + deriving Show +StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. + -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. + -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. + -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations + incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs + key Int -- a possible key for the studyTermName + name Text -- studyTermName as plain text from LDAP + deriving Show Eq Ord diff --git a/package.yaml b/package.yaml index 0aadd7a3f..83b3b006e 100644 --- a/package.yaml +++ b/package.yaml @@ -114,6 +114,7 @@ dependencies: - memcached-binary - directory-tree - lifted-base + - lattices - hsass other-extensions: @@ -170,6 +171,7 @@ default-extensions: ghc-options: - -Wall - -fno-warn-type-defaults + - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures when: 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 e4de524d2..000f3f153 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 @@ -220,7 +222,7 @@ instance RenderMessage UniWorX MsgLanguage where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) -embedRenderMessage ''UniWorX ''MessageClass ("Message" <>) +embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id @@ -251,6 +253,32 @@ instance RenderMessage UniWorX SheetType where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX StudyDegree where + renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand) + +newtype ShortStudyDegree = ShortStudyDegree StudyDegree + +instance RenderMessage UniWorX ShortStudyDegree where + renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand + +instance RenderMessage UniWorX StudyTerms where + renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand) + +newtype ShortStudyTerms = ShortStudyTerms StudyTerms + +instance RenderMessage UniWorX ShortStudyTerms where + renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand + +data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms + +instance RenderMessage UniWorX StudyDegreeTerm where + renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")" + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + + + newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) @@ -307,6 +335,7 @@ data instance ButtonClass UniWorX | BCWarning | BCDanger | BCLink + | BCMassInputAdd | BCMassInputDelete deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe (ButtonClass UniWorX) instance Finite (ButtonClass UniWorX) @@ -1021,6 +1050,7 @@ siteLayout' headingOverride widget = do addScript $ StaticR js_utils_asidenav_js addScript $ StaticR js_utils_asyncForm_js addScript $ StaticR js_utils_asyncTable_js + addScript $ StaticR js_utils_asyncTableFilter_js addScript $ StaticR js_utils_checkAll_js addScript $ StaticR js_utils_httpClient_js addScript $ StaticR js_utils_form_js @@ -1032,9 +1062,13 @@ siteLayout' headingOverride widget = do addStylesheet $ StaticR css_utils_alerts_scss addStylesheet $ StaticR css_utils_asidenav_scss addStylesheet $ StaticR css_utils_asyncForm_scss + addStylesheet $ StaticR css_utils_asyncTable_scss + addStylesheet $ StaticR css_utils_asyncTableFilter_scss + addStylesheet $ StaticR css_utils_checkbox_scss addStylesheet $ StaticR css_utils_form_scss addStylesheet $ StaticR css_utils_inputs_scss addStylesheet $ StaticR css_utils_modal_scss + addStylesheet $ StaticR css_utils_radio_scss addStylesheet $ StaticR css_utils_showHide_scss addStylesheet $ StaticR css_utils_tabber_scss addStylesheet $ StaticR css_utils_tooltip_scss @@ -1072,9 +1106,12 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) breadcrumb HomeR = return ("Uni2work" , Nothing) - breadcrumb UsersR = return ("Benutzer" , Just HomeR) - breadcrumb 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) @@ -1102,10 +1139,12 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) -- (CourseR tid ssh csh CRegisterR) -- is POST only - breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) - breadcrumb (CourseR tid ssh csh 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) @@ -1127,7 +1166,7 @@ instance YesodBreadcrumbs UniWorX where return $ if | mayList -> ("Statusmeldung", Just MessageListR) | otherwise -> ("Statusmeldung", Just HomeR) - breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) + breadcrumb (MessageListR) = return ("Statusmeldungen", Just AdminR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] @@ -1246,6 +1285,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgAdminHeading + , menuItemIcon = Just "screwdriver" + , menuItemRoute = SomeRoute AdminR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] @@ -1267,33 +1314,75 @@ pageActions (HomeR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime - , 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 @@ -1914,6 +2003,8 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate Creds{..} = runDB $ do + now <- liftIO getCurrentTime + let userIdent = CI.mk credsIdent uAuth = UniqueAuthentication userIdent @@ -1941,7 +2032,12 @@ instance YesodAuth UniWorX where return $ ServerError "LDAP lookup failed" ] - acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + acceptExisting = do + res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + _other -> return res $logDebugS "auth" $ tshow Creds{..} UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod @@ -1960,6 +2056,7 @@ instance YesodAuth UniWorX where userAuthentication | isPWHash = error "PWHash should only work for users that are already known" | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (not isDummy) userEmail <- if | Just [bs] <- userEmail' @@ -2000,16 +2097,18 @@ instance YesodAuth UniWorX where , userMailLanguages = def , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , 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" @@ -2017,15 +2116,28 @@ instance YesodAuth UniWorX where Right str <- return $ Text.decodeUtf8' v' return str + termNames = nubBy ((==) `on` CI.mk) $ do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFieldOfStudyString" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - lift $ deleteWhere [StudyFeaturesUser ==. userId] + let + studyTermCandidates = do + studyTermCandidateName <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs + return StudyTermCandidate{..} + lift $ insertMany_ studyTermCandidates - forM_ fs $ \StudyFeatures{..} -> do + lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] + forM_ fs $ \f@StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] - lift $ insertMany_ fs return $ Authenticated userId Nothing -> acceptExisting diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fe20fcd4e..0507747ed 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -2,24 +2,46 @@ module Handler.Admin where import Import import Handler.Utils +import Handler.Utils.Form.MassInput import Jobs - import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import Control.Monad.Trans.Except +import Control.Monad.Trans.Writer (mapWriterT) + +import Utils.Lens -- import Data.Time --- import qualified Data.Text as T +import Data.Char (isDigit) +import qualified Data.Text as Text -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 +import qualified Data.Set as Set +import qualified Data.Map as Map + import Database.Persist.Sql (fromSqlKey) +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils as E + +import Handler.Utils.Table.Cells +import qualified Handler.Utils.TermCandidates as Candidates -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade -- import qualified Data.UUID.Cryptographic as UUID + +getAdminR :: Handler Html +getAdminR = -- do + siteLayoutMsg MsgAdminHeading $ do + setTitleI MsgAdminHeading + [whamlet| + This shall become the Administrators' overview page. + Its current purpose is to provide links to some important admin functions + |] + -- BEGIN - Buttons needed only here data ButtonCreate = CreateMath | CreateInf -- Dummy for Example deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) @@ -34,7 +56,7 @@ instance Button UniWorX ButtonCreate where btnClasses CreateMath = [BCIsButton, BCInfo] btnClasses CreateInf = [BCIsButton, BCPrimary] --- END Button needed here +-- END Button needed only here emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm = (,) @@ -55,7 +77,7 @@ emailTestForm = (,) SelFormatTime -> t makeDemoForm :: Int -> Form (Int,Bool,Double) -makeDemoForm n = identForm FIDAdminDemo $ \html -> do -- Important: used identForm instead! +makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ (,,) <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing <* aformSection MsgFormBehaviour @@ -77,23 +99,20 @@ makeDemoForm n = identForm FIDAdminDemo $ \html -> do -- Important: used identFo getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate) + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" - ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm - 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|
@@ -126,6 +145,61 @@ postAdminTestR = do
  • #{m} |] + + {- The following demonstrates the use of @massInput@. + + @massInput@ takes as arguments: + - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?) + - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required) + - An initial value to pre-fill the field with + + @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result + -} + let + -- We define the fields of the configuration struct @MassInput@: + + -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) + -- + -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required) + mkAddForm :: ListPosition -- ^ Approximate position of the add-widget + -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 + -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique + -> FieldView UniWorX -- ^ Submit-Button for this add-widget + -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell + mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do + (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration + let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done + addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required + return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn) + mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form" + + -- | Make a single massInput-Cell + -- + -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted) + mkCellForm :: ListPosition -- ^ Position of this cell + -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@) + -> Maybe Int -- ^ Initial cell result from Argument to `massInput` + -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique + -> Form Int + mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell + (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData + return (intRes, toWidget csrf >> fvInput intView) + -- | How does the shape (`ListLength`) change if a certain cell is deleted? + deleteCell :: ListLength -- ^ Current shape + -> ListPosition -- ^ Coordinate to delete + -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions + deleteCell l pos + | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard` + | otherwise = return Map.empty + -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) + allowAdd :: ListPosition -> Natural -> ListLength -> Bool + allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases) + + -- The actual call to @massInput@ is comparatively simple: + + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing + + let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] siteLayout locallyDefinedPageHeading $ do -- defaultLayout $ do @@ -142,6 +216,22 @@ postAdminTestR = do } showDemoResult + [whamlet| +

    Mass-Input + + ^{miForm} + ^{submitButtonView} + $case miResult + $of FormMissing + $of FormFailure errs +