diff --git a/ChangeLog.md b/ChangeLog.md index f35e0e155..c50e244b7 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,19 @@ + * Version 04.05.2019 + + Kursmaterial + + * Version 29.04.2019 + + Tutorien + + Anzeige von Korrektoren auf den Kursseiten + + * Version 20.04.2019 + + Versand von Benachrichtigungen an Kursteilnehmer + + Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account + * Version 27.03.2019 Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen diff --git a/assets/lmu/logo.svg b/assets/lmu/logo.svg new file mode 100644 index 000000000..6b72bb7b9 --- /dev/null +++ b/assets/lmu/logo.svg @@ -0,0 +1,6 @@ + + + + + + diff --git a/assets/lmu/sigillum.svg b/assets/lmu/sigillum.svg new file mode 100644 index 000000000..78538233a --- /dev/null +++ b/assets/lmu/sigillum.svg @@ -0,0 +1,19 @@ + + + + + + + image/svg+xml + + + + + + + + + + + + diff --git a/assets/logo-o2.svg b/assets/logo-o2.svg deleted file mode 100644 index 80620673b..000000000 --- a/assets/logo-o2.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/assets/logo.png b/assets/logo.png deleted file mode 100644 index 4ef03212e..000000000 Binary files a/assets/logo.png and /dev/null differ diff --git a/build.sh b/build.sh index 13a8b2490..9b4f5a2e2 100755 --- a/build.sh +++ b/build.sh @@ -1,4 +1,4 @@ #!/usr/bin/env bash -exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev +exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@ echo Build task completed. diff --git a/config/settings.yml b/config/settings.yml index 3211d42db..974b2e7e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -27,7 +27,12 @@ notification-rate-limit: 3600 notification-collate-delay: 300 notification-expiration: 259201 session-timeout: 7200 +jwt-expiration: 604800 +jwt-encoding: HS256 maximum-content-length: 52428800 +health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller +health-check-http: "_env:HEALTHCHECK_HTTP:true" +health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/db.sh b/db.sh index 8861a2ac4..3d80bf68f 100755 --- a/db.sh +++ b/db.sh @@ -1,4 +1,6 @@ #!/usr/bin/env bash # Options: see /test/Database.hs (Main) -stack build --fast --flag uniworx:library-only --flag uniworx:dev +set -e + +stack build --fast --flag uniworx:-library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/haddock.sh b/haddock.sh index aaceeb329..7414e60e8 100755 --- a/haddock.sh +++ b/haddock.sh @@ -1,3 +1,14 @@ #!/usr/bin/env bash -exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal +move-back() { + mv -v .stack-work .stack-work-doc + [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work +} + +if [[ -d .stack-work-doc ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build + mv -v .stack-work-doc .stack-work + trap move-back EXIT +fi + +stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal diff --git a/hlint.sh b/hlint.sh new file mode 100755 index 000000000..74a2a9fb7 --- /dev/null +++ b/hlint.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint diff --git a/messages/frontend/de.msg b/messages/frontend/de.msg new file mode 100644 index 000000000..f01c31640 --- /dev/null +++ b/messages/frontend/de.msg @@ -0,0 +1,4 @@ +FilesSelected: Dateien ausgewählt +SelectFile: Datei auswählen +SelectFiles: Datei(en) auswählen +AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für deine Hilfe! \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e5eed4900..19941107c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -10,6 +10,11 @@ BtnSave: Speichern BtnCandidatesInfer: Studienfachzuordnung automatisch lernen BtnCandidatesDeleteConflicts: Konflikte löschen BtnCandidatesDeleteAll: Alle Beobachtungen löschen +BtnResetTokens: Authorisierungs-Tokens invalidieren +BtnLecInvAccept: Annehmen +BtnLecInvDecline: Ablehnen +BtnCorrInvAccept: Annehmen +BtnCorrInvDecline: Ablehnen Aborted: Abgebrochen Remarks: Hinweise @@ -19,6 +24,7 @@ RegisteredSince date@Text: Angemeldet seit #{date} RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis +RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" GenericKey: Schlüssel GenericShort: Kürzel @@ -64,10 +70,12 @@ CourseShort: Kürzel CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. +TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Anmeldung erfolgreich CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach +CourseTutorial: Tutorium CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort @@ -114,6 +122,10 @@ CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +CourseUserSendMail: Mitteilung verschicken +TutorialUserDeregister: Vom Tutorium Abmelden +TutorialUserSendMail: Mitteilung verschicken +TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -122,7 +134,7 @@ CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein -CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte +CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -136,8 +148,8 @@ SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren -SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. -SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. +SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wurde gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh} SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}! @@ -159,21 +171,21 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe -SheetVisibleFrom: Sichtbar ab -SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist -SheetActiveFrom: Aktiv ab -SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich -SheetActiveTo: Abgabefrist +SheetVisibleFrom: Sichtbar für Teilnehmer ab +SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können +SheetActiveFrom: Beginn Abgabezeitraum +SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich +SheetActiveTo: Ende Abgabezeitraum SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren SheetPseudonym: Persönliches Abgabe-Pseudonym SheetGeneratePseudonym: Generieren -SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen -SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen -SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden -SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden +SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen +SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen +SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden +SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden Deadline: Abgabe @@ -202,10 +214,40 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} CorrectorAssignTitle: Korrektor zuweisen +MaterialName: Name +MaterialType: Art +MaterialTypePlaceholder: Folien, Code, Beispiel, ... +MaterialTypeSlides: Folien +MaterialTypeCode: Code +MaterialTypeExample: Beispiel +MaterialDescription: Beschreibung +MaterialVisibleFrom: Sichtbar für Teilnehmer ab +MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren +MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar! +MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}! +MaterialFiles: Dateien +MaterialHeading materialName@MaterialName: Material "#{materialName}" +MaterialListHeading: Materialien +MaterialNewHeading: Neues Material veröffentlichen +MaterialNewTitle: Neues Material +MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren +MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren +MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{display tid}-#{display ssh}-#{csh} +MaterialDeleteQuestion: Wollen Sie das unten aufgeführte Material wirklich löschen? +MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht + Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. +UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. +UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. +UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig. +UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert. +UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. @@ -218,6 +260,8 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. +UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. @@ -234,6 +278,11 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. +UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer. +UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium. +UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs. +UnauthorizedTutor: Sie sind nicht Tutor. +UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -241,10 +290,10 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic TooManyParticipants: Es wurden zu viele Mitabgebende angegeben AddCorrector: Zusätzlicher Korrektor -CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen +CorrectorExists: Nutzer ist bereits als Korrektor eingetragen SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName} CountTutProp: Tutorien zählen gegen Proportion -AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen +AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen Corrector: Korrektor Correctors: Korrektoren CorState: Status @@ -254,8 +303,8 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium -RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt -DeleteRow: Zeile entfernen +RowCount count@Int64: #{display count} #{pluralDE count "passender Eintrag" "passende Einträge"} insgesamt +DeleteRow: Entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorUpdated: Korrektor erfolgreich aktualisiert CorrectorsUpdated: Korrektoren erfolgreich aktualisiert @@ -275,6 +324,9 @@ ImpressumHeading: Impressum DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen +NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} +TokensLastReset: Tokens zuletzt invalidiert +TokensResetSuccess: Authorisierungs-Tokens invalidiert HomeOpenCourses: Kurse mit offener Registrierung HomeUpcomingSheets: Anstehende Übungsblätter @@ -291,10 +343,14 @@ Plugin: Plugin Ident: Identifikation LastLogin: Letzter Login Settings: Individuelle Benutzereinstellungen -SettingsUpdate: Einstellungen wurden gespeichert. +SettingsUpdate: Einstellungen erfolgreich gespeichert +NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert Never: Nie +PreviouslyUploadedInfo: Bereits hochgeladene Dateien: +PreviouslyUploadedDeletionInfo: (Nicht ausgewählte Dateien werden gelöscht) MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) +AddMoreFiles: Weitere Dateien hinzufügen: NrColumn: Nr SelectColumn: Auswahl @@ -350,6 +406,8 @@ Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung +VisibleFrom: Veröffentlicht +AccessibleSince: Verfügbar seit Corrected: Korrigiert @@ -387,6 +445,8 @@ LecturerFor: Dozent LecturersFor: Dozenten AssistantFor: Assistent AssistantsFor: Assistenten +TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"} +CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} UserListTitle: Komprehensive Benutzerliste AccessRightsSaved: Berechtigungsänderungen wurden gespeichert. @@ -421,6 +481,7 @@ LDAPLoginTitle: Campus-Login PWHashLoginTitle: Uni2work-Login PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an! DummyLoginTitle: Development-Login +LoginNecessary: Bitte melden Sie sich dazu vorher an! CorrectorNormal: Normal CorrectorMissing: Abwesend @@ -435,9 +496,10 @@ UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken -SheetNoSubmissions: Keine Abgabe -SheetCorrectorSubmissions: Abgabe extern mit Pseudonym -SheetUserSubmissions: Direkte Abgabe +NoSubmissions: Keine Abgabe +CorrectorSubmissions: Abgabe extern mit Pseudonym +UserSubmissions: Direkte Abgabe +BothSubmissions: Abgabe direkt & extern mit Pseudonym SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können. @@ -496,7 +558,7 @@ MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@She MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. -MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen +MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (display n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (display num <> " Teilnehmern")}. MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt @@ -510,6 +572,15 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage +MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} + +CommCourseSubject: Kursmitteilung +MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter +InvitationAcceptDecline: Einladung annehmen/ablehnen + +MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn} + +MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte @@ -548,12 +619,13 @@ SheetGroupNoGroups: Keine Gruppenabgabe SheetGroupMaxGroupsize: Maximale Gruppengröße SheetFiles: Übungsblatt-Dateien +SheetFileTypeHeader: Zugehörigkeit NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben -NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen +NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert @@ -584,6 +656,7 @@ HelpAnswer: Antworten an HelpUser: Meinen Benutzeraccount HelpAnonymous: Keine Antwort (Anonym) HelpEmail: E-Mail +HelpSubject: Betreff HelpRequest: Supportanfrage / Verbesserungsvorschlag HelpProblemPage: Problematische Seite HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. @@ -658,15 +731,19 @@ MenuInformation: Informationen MenuImpressum: Impressum MenuDataProt: Datenschutz MenuVersion: Versionsgeschichte +MenuInstance: Instanz-Identifikation +MenuHealth: Instanz-Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer +MenuUserNotifications: Benachrichtigungs-Einstellungen MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten MenuAdminErrMsg: Fehlermeldung entschlüsseln @@ -679,6 +756,12 @@ MenuCorrections: Korrekturen MenuCorrectionsOwn: Meine Korrekturen MenuSubmissions: Abgaben MenuSheetList: Übungsblätter +MenuMaterialList: Material +MenuMaterialNew: Neues Material veröffentlichen +MenuMaterialEdit: Material bearbeiten +MenuMaterialDelete: Material löschen +MenuTutorialList: Tutorien +MenuTutorialNew: Neues Tutorium anlegen MenuSheetNew: Neues Übungsblatt anlegen MenuSheetCurrent: Aktuelles Übungsblatt MenuSheetOldUnassigned: Abgaben ohne Korrektor @@ -695,20 +778,26 @@ MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten MenuAuthPreds: Authorisierungseinstellungen +MenuTutorialDelete: Tutorium löschen +MenuTutorialEdit: Tutorium editieren 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 +AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung AuthTagLecturer: Nutzer ist Dozent AuthTagCorrector: Nutzer ist Korrektor +AuthTagTutor: Nutzer ist Tutor AuthTagTime: Zeitliche Einschränkungen sind erfüllt -AuthTagRegistered: Nutzer ist Kursteilnehmer +AuthTagCourseRegistered: Nutzer ist Kursteilnehmer +AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagParticipant: Nutzer ist mit Kurs assoziiert +AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe AuthTagCapacity: Kapazität ist ausreichend AuthTagEmpty: Kurs hat keine Teilnehmer AuthTagMaterials: Kursmaterialien sind freigegeben @@ -716,6 +805,7 @@ AuthTagOwner: Nutzer ist Besitzer AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren +AuthTagSelf: Nutzer greift nur auf eigene Daten zu AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend @@ -724,9 +814,128 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n " 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 +DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde -MassInputAddDimension: Hinzufügen -MassInputDeleteCell: Entfernen +MassInputAddDimension: + +MassInputDeleteCell: - -NavigationFavourites: Favoriten \ No newline at end of file +NavigationFavourites: Favoriten + +CommSubject: Betreff +CommBody: Nachricht +CommRecipients: Empfänger +CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht +CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert +CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt + +CommCourseHeading: Kursmitteilung +CommTutorialHeading: Tutorium-Mitteilung + +RecipientCustom: Weitere Empfänger +RecipientToggleAll: Alle/Keine + +RGCourseParticipants: Kursteilnehmer +RGCourseLecturers: Kursverwalter +RGCourseCorrectors: Korrektoren +RGCourseTutors: Tutoren +RGTutorialParticipants: Tutorium-Teilnehmer + +MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) +MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich +EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt. + +LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen +LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt +CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName} +CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein. + +CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen +CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt +SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} +SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. + +TutorInvitationAccepted tutn@TutorialName: Sie wurden als Tutor für #{tutn} eingetragen +TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #{tutn} zu werden, abgelehnt +TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} +TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. + +InvitationAction: Aktion +InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden +InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten +InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger Eintrag bereits existiert +InvitationDeclined: Einladung wurde abgelehnt +BtnInviteAccept: Einladung annehmen +BtnInviteDecline: Einladung ablehnen + +LecturerType: Rolle +ScheduleKindWeekly: Wöchentlich + +ScheduleRegular: Planmäßiger Termin +ScheduleRegularKind: Plan +WeekDay: Wochentag +Day: Tag +OccurenceStart: Beginn +OccurenceEnd: Ende +ScheduleExists: Dieser Plan existiert bereits + +ScheduleExceptions: Termin-Ausnahmen +ScheduleExceptionsTip: Ausfälle überschreiben planmäßiges Stattfinden. Außerplanmäßiges Stattfinden überschreibt Ausfall. +ExceptionKind: Termin ... +ExceptionKindOccur: Findet statt +ExceptionKindNoOccur: Findet nicht statt +ExceptionExists: Diese Ausnahme existiert bereits +ExceptionNoOccurAt: Termin + +TutorialType: Typ +TutorialName: Bezeichnung +TutorialParticipants: Teilnehmer +TutorialCapacity: Kapazität +TutorialFreeCapacity: Freie Plätze +TutorialRoom: Regulärer Raum +TutorialTime: Zeit +TutorialRegistered: Angemeldet +TutorialRegGroup: Registrierungs-Gruppe +TutorialRegisterFrom: Anmeldungen ab +TutorialRegisterTo: Anmeldungen bis +TutorialDeregisterUntil: Abmeldungen bis +TutorialsHeading: Tutorien +TutorialEdit: Bearbeiten +TutorialDelete: Löschen + +CourseTutorials: Übungen + +ParticipantsN n@Int: Teilnehmer +TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen? +TutorialDeleted: Tutorium gelöscht + +TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Tutorium #{tutn} angemeldet +TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Tutorium #{tutn} abgemeldet + +TutorialNameTip: Muss eindeutig sein +TutorialCapacityNonPositive: Kapazität muss größer oder gleich null sein +TutorialCapacityTip: Beschränkt wieviele Studenten sich zu diesem Tutorium anmelden können +TutorialRegGroupTip: Studenten können sich in jeweils maximal einem Tutorium pro Registrierungs-Gruppe anmelden. Ist bei zwei oder mehr Tutorien keine Registrierungs-Gruppe gesetzt zählen diese als in verschiedenen Registrierungs-Gruppen +TutorialRoomPlaceholder: Raum +TutorialTutors: Tutoren +TutorialTutorAlreadyAdded: Ein Tutor mit dieser E-Mail ist bereits für dieses Tutorium eingetragen + +TutorialNew: Neues Tutorium + +TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn} +TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt + +TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten + +MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. + +HealthReport: Instanz-Zustand +InstanceIdentification: Instanz-Identifikation + +InstanceId: Instanz-Nummer +ClusterId: Cluster-Nummer + +HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können +HealthSMTPConnect: SMTP-Server kann erreicht werden +HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus diff --git a/models/invitations b/models/invitations new file mode 100644 index 000000000..c1d15148c --- /dev/null +++ b/models/invitations @@ -0,0 +1,5 @@ +Invitation + email UserEmail + for Value + data Value + UniqueInvitation email for \ No newline at end of file diff --git a/models/materials b/models/materials new file mode 100644 index 000000000..062ab3232 --- /dev/null +++ b/models/materials @@ -0,0 +1,12 @@ +Material -- course material for disemination to course participants + course CourseId + name (CI Text) + type Text Maybe + description Html Maybe + visibleFrom UTCTime Maybe -- Invisible to enrolled participants before + lastEdit UTCTime + UniqueMaterial course name + deriving Generic +MaterialFile -- a file that is part of a material distribution + material MaterialId + file FileId \ No newline at end of file diff --git a/models/rooms b/models/rooms deleted file mode 100644 index 2ef670fd3..000000000 --- a/models/rooms +++ /dev/null @@ -1,32 +0,0 @@ --- 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 - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe -- name of building - roomfinder Text Maybe -- external url for LMU Roomfinder --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/sheets b/models/sheets index e13fc2d47..f8d21a6c2 100644 --- a/models/sheets +++ b/models/sheets @@ -10,8 +10,7 @@ Sheet -- exercise sheet for a given course 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? + submissionMode SubmissionMode -- Submission upload by students and/or through tutors? autoDistribute Bool default=false -- Should correctors be assigned submissions automagically? CourseSheet course name deriving Generic diff --git a/models/tutorials b/models/tutorials index 3afed739e..78571389c 100644 --- a/models/tutorials +++ b/models/tutorials @@ -1,11 +1,21 @@ --- 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 + name TutorialName + course CourseId + type (CI Text) -- "Tutorium", "Zentralübung", ... + capacity Int Maybe -- limit for enrolment in this tutorial + room Text + time Occurences + regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + lastChanged UTCTime default='NOW()' + UniqueTutorial course name +Tutor tutorial TutorialId - UniqueTutorialUser user tutorial + user UserId + UniqueTutor tutorial user +TutorialParticipant + tutorial TutorialId + user UserId + UniqueTutorialParticipant tutorial user \ No newline at end of file diff --git a/models/users b/models/users index 80e5ff43c..cd08164d1 100644 --- a/models/users +++ b/models/users @@ -11,6 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date + tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) 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) diff --git a/package.yaml b/package.yaml index 339ecff3e..4edc4d864 100644 --- a/package.yaml +++ b/package.yaml @@ -85,6 +85,7 @@ dependencies: - scientific - tz - system-locale + - th-lift - th-lift-instances - gitrev - Glob @@ -117,6 +118,14 @@ dependencies: - lattices - hsass - semigroupoids + - jose-jwt + - mono-traversable + - lens-aeson + - systemd + - lifted-async + - streaming-commons + - hourglass + - unix other-extensions: - GeneralizedNewtypeDeriving @@ -168,12 +177,14 @@ default-extensions: - PackageImports - TypeApplications - RecursiveDo + - TypeFamilyDependencies ghc-options: - -Wall - -fno-warn-type-defaults - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures + - -fno-max-relevant-binds when: - condition: flag(pedantic) @@ -218,6 +229,9 @@ executables: dependencies: - uniworx other-modules: [] + when: + - condition: flag(library-only) + buildable: false # Test suite tests: diff --git a/routes b/routes index d558de967..747207cc0 100644 --- a/routes +++ b/routes @@ -13,9 +13,14 @@ -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) +-- !course-registered -- participant for this course (no effect outside of courses) +-- !tutorial-registered -- participant for this tutorial (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) +-- +-- !register-group -- user is member in no other tutorial with same register group +-- -- !owner -- part of the group of owners of this submission +-- !self -- route refers to the currently logged in user themselves -- !capacity -- course this route is associated with has at least one unit of participant capacity -- !empty -- course this route is associated with has no participants whatsoever -- @@ -34,73 +39,95 @@ /favicon.ico FaviconR GET !free /robots.txt RobotsR GET !free -/ HomeR GET !free -/users UsersR GET -- no tags, i.e. admins only -/users/#CryptoUUIDUser AdminUserR GET POST -/users/#CryptoUUIDUser/delete AdminUserDeleteR POST -/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 +/ HomeR GET !free +/users UsersR GET -- no tags, i.e. admins only +/users/#CryptoUUIDUser AdminUserR GET POST +/users/#CryptoUUIDUser/delete AdminUserDeleteR POST +/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation +/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self +/admin AdminR GET +/admin/features AdminFeaturesR GET POST +/admin/test AdminTestR GET POST +/admin/errMsg AdminErrMsgR GET POST -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !lecturer -/info/data DataProtR GET !free -/impressum ImpressumR GET !free -/version VersionR GET !free +/health HealthR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !lecturer +/info/data DataProtR GET !free +/impressum ImpressumR GET !free +/version VersionR GET !free -/help HelpR GET POST !free +/help HelpR GET POST !free -/user ProfileR GET POST !free -/user/profile ProfileDataR GET !free -/user/authpreds AuthPredsR GET POST !free +/user ProfileR GET POST !free +/user/profile ProfileDataR GET !free +/user/authpreds AuthPredsR GET POST !free -/term TermShowR GET !free -/term/current TermCurrentR GET !free -/term/edit TermEditR GET POST -/term/#TermId/edit TermEditExistR GET POST -!/term/#TermId TermCourseListR GET !free -!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free +/term TermShowR GET !free +/term/current TermCurrentR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET POST +!/term/#TermId TermCourseListR GET !free +!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET !development -/school/#SchoolId SchoolShowR GET !development +/school SchoolListR GET !development +/school/#SchoolId SchoolShowR GET !development -- For Pattern Synonyms see Foundation -/course/ CourseListR GET !free -!/course/new CourseNewR GET POST !lecturer -/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: - / CShowR GET !free - /register CRegisterR POST !timeANDcapacity - /edit CEditR GET POST - /delete CDeleteR GET POST !lecturerANDempty - /users CUsersR GET POST - /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant - /correctors CHiWisR GET - /notes CNotesR GET POST !corrector - /subs CCorrectionsR GET POST - /ex SheetListR GET !registered !materials !corrector - /ex/new SheetNewR GET POST - /ex/current SheetCurrentR GET !registered !materials !corrector - /ex/unassigned SheetOldUnassigned GET +/course/ CourseListR GET !free +!/course/new CourseNewR GET POST !lecturer +/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: + / CShowR GET !free + /register CRegisterR GET POST !timeANDcapacity + /edit CEditR GET POST + /lecturer-invite CLecInviteR GET POST + /delete CDeleteR GET POST !lecturerANDempty + /users CUsersR GET POST + /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant + /correctors CHiWisR GET + /communication CCommR GET POST + /notes CNotesR GET POST !corrector + /subs CCorrectionsR GET POST + /ex SheetListR GET !course-registered !materials !corrector + /ex/new SheetNewR GET POST + /ex/current SheetCurrentR GET !course-registered !materials !corrector + /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: - /show SShowR GET !timeANDregistered !timeANDmaterials !corrector - /edit SEditR GET POST - /delete SDelR GET POST - /subs SSubsR GET POST -- for lecturer only - !/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions - !/subs/own SubmissionOwnR GET !free -- just redirect + /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector + /edit SEditR GET POST + /delete SDelR GET POST + /subs SSubsR GET POST -- for lecturer only + !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions + !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread - /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector - /delete SubDelR GET POST !ownerANDtime - /assign SAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDreadANDrated - !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector - /correctors SCorrR GET POST - /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions - !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector + / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread + /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector + /delete SubDelR GET POST !ownerANDtime + /assign SAssignR GET POST !lecturerANDtime + /correction CorrectionR GET POST !corrector !ownerANDreadANDrated + !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector + /correctors SCorrR GET POST + /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions + /corrector-invite/ SCorrInviteR GET POST + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + /file MaterialListR GET !course-registered !materials !corrector !tutor + /file/new MaterialNewR GET POST + /file/#MaterialName MaterialR: + /edit MEditR GET POST + /delete MDelR GET POST + /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + /load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + /tuts CTutorialListR GET !tutor + /tuts/new CTutorialNewR GET POST + /tuts/#TutorialName TutorialR: + /edit TEditR GET POST + /delete TDeleteR GET POST + /participants TUsersR GET POST !tutor + /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered + /communication TCommR GET POST !tutor + /tutor-invite TInviteR GET POST /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 20824d216..cc8843303 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Application - ( getApplicationDev, getAppDevSettings + ( getAppDevSettings , appMain , develMain , makeFoundation @@ -24,8 +24,10 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettings, setHost, + runSettingsSocket, setHost, + setBeforeMainLoop, setOnException, setPort, getPort) +import Data.Streaming.Network (bindPortTCP) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -62,7 +64,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..)) import qualified Data.HashMap.Strict as HashMap -import Control.Lens +import Utils.Lens import Data.Proxy @@ -71,7 +73,14 @@ import qualified Data.Aeson as Aeson import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached - + +import qualified System.Systemd.Daemon as Systemd +import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) +import System.Environment (lookupEnv) +import System.Posix.Process (getProcessID) + +import Control.Monad.Trans.State (execStateT) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -86,9 +95,12 @@ import Handler.School import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.Tutorial import Handler.Corrections +import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage +import Handler.Health -- This line actually creates our YesodDispatch instance. It is the second half @@ -101,7 +113,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX -makeFoundation appSettings@AppSettings{..} = do +makeFoundation appSettings'@AppSettings{..} = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager @@ -135,13 +147,14 @@ makeFoundation appSettings@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO + appHealthReport <- liftIO $ newTVarIO Nothing -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -153,38 +166,54 @@ makeFoundation appSettings@AppSettings{..} = do (error "sessionKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") - logFunc loc src lvl str = do - f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) - f loc src lvl str + (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") - flip runLoggingT logFunc $ do - $logDebugS "InstanceID" $ UUID.toText appInstanceID - -- logDebugS "Configuration" $ tshow appSettings + runAppLoggingT tempFoundation $ do + $logInfoS "InstanceID" $ UUID.toText appInstanceID + -- logDebugS "Configuration" $ tshow appSettings' - smtpPool <- traverse createSmtpPool appSmtpConf + smtpPool <- for appSmtpConf $ \c -> do + $logDebugS "setup" "SMTP-Pool" + createSmtpPool c - appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf + appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do + $logDebugS "setup" "Widget-Memcached" + createWidgetMemcached c -- Create the database connection pool + $logDebugS "setup" "PostgreSQL-Pool" sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) - ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - + ldapPool <- for appLdapConf $ \LdapConf{..} -> do + $logDebugS "setup" "LDAP-Pool" + createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + -- Perform database migration using our application's logging settings. + $logDebugS "setup" "Migration" migrateAll `runSqlPool` sqlPool + $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool + appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool + appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached - - handleJobs foundation + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID -- Return the foundation + $logDebugS "setup" "Done" return foundation +runAppLoggingT :: UniWorX -> LoggingT m a -> m a +runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc + where + logFunc loc src lvl str = do + f <- messageLoggerSource app <$> readTVarIO loggerTVar + f loc src lvl str + clusterSetting :: forall key m p. ( MonadIO m , ClusterSetting key @@ -203,7 +232,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do new <- initClusterSetting proxy void . insert $ ClusterConfig key (Aeson.toJSON new) return new - + readInstanceIDFile :: MonadIO m => FilePath -> m UUID readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS where @@ -224,7 +253,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do let withLogging :: LoggingT IO a -> IO a withLogging = flip runLoggingT logFunc - + mkConnection = withLogging $ do $logInfoS "SMTP" "Opening new connection" liftIO mkConnection' @@ -265,7 +294,7 @@ makeLogWare app = do logger <- readTVarIO . snd $ appLogger app logWare <- mkRequestLogger def { outputFormat = bool - (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app) + (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader) (Detailed True) logDetailed , destination = Logger $ loggerSet logger @@ -287,8 +316,20 @@ makeLogWare app = do -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings - & setPort (appPort $ appSettings foundation) - & setHost (appHost $ appSettings foundation) + & setBeforeMainLoop (runAppLoggingT foundation $ do + let notifyReady = do + $logInfoS "setup" "Ready" + void $ liftIO Systemd.notifyReady + if + | foundation ^. _appHealthCheckDelayNotify + -> void . fork $ do + atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd) + notifyReady + | otherwise + -> notifyReady + ) + & setHost (foundation ^. _appHost) + & setPort (foundation ^. _appPort) & setOnException (\_req e -> when (defaultShouldDisplayException e) $ do logger <- readTVarIO . snd $ appLogger foundation @@ -300,43 +341,65 @@ warpSettings foundation = defaultSettings LevelError (toLogStr $ "Exception from Warp: " ++ show e)) --- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) -getApplicationDev = do - settings <- getAppDevSettings - foundation <- makeFoundation settings - wsettings <- liftIO . getDevSettings $ warpSettings foundation - app <- makeApplication foundation - return (wsettings, app) +getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv -getAppDevSettings :: MonadIO m => m AppSettings -getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +adjustSettings :: MonadIO m => AppSettings -> m AppSettings +adjustSettings = execStateT $ do + watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC" + watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID" + myProcessID <- liftIO getProcessID + case watchdogMicroSec of + Just wInterval + | maybe True (== myProcessID) watchdogProcess + -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) + _other -> return () -- | main function for use by yesod devel develMain :: IO () -develMain = runResourceT $ - liftIO . develMainHelper . return =<< getApplicationDev +develMain = runResourceT $ do + settings <- getAppDevSettings + foundation <- makeFoundation settings + wsettings <- liftIO . getDevSettings $ warpSettings foundation + app <- makeApplication foundation + + handleJobs foundation + liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. appMain :: MonadResourceBase m => m () appMain = runResourceT $ do - -- Get the settings from all relevant sources - settings <- liftIO $ - loadYamlSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - - -- allow environment variables to override - useEnv + settings <- getAppSettings -- Generate the foundation from the settings foundation <- makeFoundation settings - -- Generate a WAI Application from the foundation - app <- makeApplication foundation + runAppLoggingT foundation $ do + $logDebugS "setup" "Job-Handling" + handleJobs foundation - -- Run the application with Warp - liftIO $ runSettings (warpSettings foundation) app + -- Generate a WAI Application from the foundation + app <- makeApplication foundation + + -- Run the application with Warp + activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames + sockets <- case activatedSockets of + Just socks@(_ : _) -> do + $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|] + return $ fst <$> socks + _other -> do + let + host = foundation ^. _appHost + port = foundation ^. _appPort + $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] + liftIO $ pure <$> bindPortTCP port host + + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app + case sockets of + [] -> $logErrorS "bind" "No sockets to listen on" + [s] -> liftIO $ runWarp s + ss -> liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) ss -------------------------------------------------------------- @@ -344,18 +407,19 @@ appMain = runResourceT $ do -------------------------------------------------------------- foundationStoreNum :: Word32 foundationStoreNum = 2 - + getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings + handleJobs foundation wsettings <- liftIO . getDevSettings $ warpSettings foundation app1 <- makeApplication foundation let foundationStore = Store foundationStoreNum liftIO $ deleteStore foundationStore liftIO $ writeStore foundationStore foundation - + return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () @@ -384,6 +448,6 @@ addPWEntry :: User -> Text {-^ Password -} -> IO () addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do - PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings + PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 2131bf527..e4c5aee74 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ ] -- ldapConfig :: UniWorX -> LDAPConfig --- ldapConfig _app@(appSettings -> settings) = LDAPConfig +-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig -- { usernameFilter = \u -> principalName <> "=" <> u -- , identifierModifier -- , ldapUri = appLDAPURI settings diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 899047c3b..4914bac78 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(.. import Data.Aeson.Encoding (text) +instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where + type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey + cryptoIDKey f = ask >>= f + + -- Generates CryptoUUID... and CryptoFileName... Datatypes decCryptoIDs [ ''SubmissionId , ''FileId @@ -53,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece - - -newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) - deriving (Show, Read, Eq) - -pattern NewSubmission :: SubmissionMode -pattern NewSubmission = SubmissionMode Nothing -pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode -pattern ExistingSubmission cID = SubmissionMode (Just cID) - -instance PathPiece SubmissionMode where - fromPathPiece "new" = Just $ SubmissionMode Nothing - fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s - - toPathPiece (SubmissionMode Nothing) = "new" - toPathPiece (SubmissionMode (Just x)) = toPathPiece x - - diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs new file mode 100644 index 000000000..66ff1df61 --- /dev/null +++ b/src/Data/Aeson/Types/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Aeson.Types.Instances + ( + ) where + +import ClassyPrelude + +import Data.Aeson.Types (Parser, Value) +import Control.Monad.Catch + +import Data.Binary (Binary) + +import Data.HashMap.Strict.Instances () +import Data.Vector.Instances () + + +instance MonadThrow Parser where + throwM = fail . show + + +instance Binary Value diff --git a/src/Data/HashMap/Strict/Instances.hs b/src/Data/HashMap/Strict/Instances.hs new file mode 100644 index 000000000..7d56f03a8 --- /dev/null +++ b/src/Data/HashMap/Strict/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.HashMap.Strict.Instances + ( + ) where + +import ClassyPrelude + +import Data.Binary (Binary(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + + +instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where + put = put . HashMap.toList + get = HashMap.fromList <$> get diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs new file mode 100644 index 000000000..3fc16cd43 --- /dev/null +++ b/src/Data/HashSet/Instances.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.HashSet.Instances + ( + ) where + +import ClassyPrelude + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +import Data.Binary (Binary(..)) + + +instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where + get = HashSet.fromList <$> get + put = put . HashSet.toList diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs new file mode 100644 index 000000000..55981d6ff --- /dev/null +++ b/src/Data/NonNull/Instances.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.NonNull.Instances + ( + ) where + +import ClassyPrelude + +import Data.Aeson + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance ToJSON a => ToJSON (NonNull a) where + toJSON = toJSON . toNullable + +instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where + parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable + + +instance Hashable a => Hashable (NonNull a) where + hashWithSalt s = hashWithSalt s . toNullable + + +instance (Binary a, MonoFoldable a) => Binary (NonNull a) where + get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable + put = Binary.put . toNullable diff --git a/src/Data/Set/Instances.hs b/src/Data/Set/Instances.hs new file mode 100644 index 000000000..9dc1c48cd --- /dev/null +++ b/src/Data/Set/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Set.Instances + ( + ) where + +import ClassyPrelude + +import Data.Set (Set) +import qualified Data.Set as Set + + +instance (Ord a, Hashable a) => Hashable (Set a) where + hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs new file mode 100644 index 000000000..1783ac465 --- /dev/null +++ b/src/Data/Time/Clock/Instances.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.Clock.Instances + ( + ) where + +import ClassyPrelude + +import Data.Time.Clock + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +deriving instance Generic UTCTime + + +instance Binary Day where + get = ModifiedJulianDay <$> Binary.get + put = Binary.put . toModifiedJulianDay + +instance Binary DiffTime where + get = fromRational <$> Binary.get + put = Binary.put . toRational + +instance Binary UTCTime diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs new file mode 100644 index 000000000..1dd097e9f --- /dev/null +++ b/src/Data/Universe/TH.hs @@ -0,0 +1,69 @@ +module Data.Universe.TH + ( finiteEnum + , deriveUniverse + , deriveFinite + ) where + +import Prelude + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Data.Universe +import Data.Universe.Helpers (interleave) + +import Control.Monad (unless) + +import Data.List (elemIndex) + + +finiteEnum :: Name -> DecsQ +-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances +finiteEnum tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + tUniverse = [e|universeF :: [$(datatype)]|] + + [d| + instance Bounded $(datatype) where + minBound = head $(tUniverse) + maxBound = last $(tUniverse) + + instance Enum $(datatype) where + toEnum n + | n >= 0 + , n < length $(tUniverse) + = $(tUniverse) !! n + | otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds" + fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse) + + enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))] + enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))] + |] + +deriveUniverse, deriveFinite :: Name -> DecsQ +deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|] +deriveFinite tName = fmap concat . sequence $ + [ deriveUniverse' [e|concat|] [e|universeF|] tName + , do + DatatypeInfo{..} <- reifyDatatype tName + [d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|] + ] + +deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ +deriveUniverse' interleaveExp universeExp tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + consUniverse ConstructorInfo{..} = do + unless (null constructorVars) $ + fail "Constructors with variables no supported" + + foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields + + pure <$> instanceD (cxt []) [t|Universe $(datatype)|] + [ funD 'universe + [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) [] + ] + ] diff --git a/src/Data/Vector/Instances.hs b/src/Data/Vector/Instances.hs new file mode 100644 index 000000000..953130328 --- /dev/null +++ b/src/Data/Vector/Instances.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Vector.Instances + ( + ) where + +import ClassyPrelude + +import Data.Vector (Vector) +import qualified Data.Vector as Vector + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance Binary a => Binary (Vector a) where + get = Vector.fromList <$> Binary.get + put = Binary.put . Vector.toList diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6c89e6c96..38105a37a 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,6 +7,7 @@ module Database.Esqueleto.Utils , SqlIn(..) , mkExactFilter, mkExactFilterWith , mkContainsFilter + , mkExistsFilter , anyFilter, allFilter ) where @@ -18,9 +19,9 @@ import Database.Esqueleto.Utils.TH -- --- Description : Convenience for using @Esqueleto@, +-- Description : Convenience for using `Esqueleto`, -- intended to be imported qualified --- just like Esqueleto +-- just like @Esqueleto@ -- ezero = E.val (0 :: Int64) @@ -43,13 +44,13 @@ hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) => 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) +-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) any :: Foldable f => (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) +-- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated) all :: Foldable f => (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) all test = F.foldr (\needle acc -> acc E.&&. test needle) true @@ -81,7 +82,7 @@ mkExactFilter :: (PersistField a) -> E.SqlExpr (E.Value Bool) mkExactFilter = mkExactFilterWith id --- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ +-- | like `mkExactFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` mkExactFilterWith :: (PersistField b) => (a -> b) -- ^ type conversion -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element @@ -104,6 +105,15 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias +mkExistsFilter :: PathPiece a + => (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set a + -> E.SqlExpr (E.Value Bool) +mkExistsFilter query row criterias + | Set.null criterias = true + | otherwise = any (E.exists . query row) criterias + -- | Combine several filters, using logical or anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) @@ -122,4 +132,4 @@ allFilter :: (Foldable f) -> E.SqlExpr (E.Value Bool) allFilter fltrs needle criterias = F.foldr aux true fltrs where - aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.&&. acc diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs index 770b71d71..66966913c 100644 --- a/src/Database/Persist/TH/Directory.hs +++ b/src/Database/Persist/TH/Directory.hs @@ -2,26 +2,35 @@ module Database.Persist.TH.Directory ( persistDirectoryWith ) where -import ClassyPrelude hiding (mapM_, toList) +import ClassyPrelude import Database.Persist.TH (parseReferences) import Database.Persist.Quasi (PersistSettings) -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified System.IO as SIO +import System.FilePath import qualified System.Directory.Tree as DirTree -import Data.Foldable (Foldable(..), mapM_) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) + +import Control.Lens + persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp persistDirectoryWith settings dir = do - files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do - h <- SIO.openFile fp SIO.ReadMode - SIO.hSetEncoding h SIO.utf8_bom - Text.hGetContents h - mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files + files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do + fn <- MaybeT . return . fromNullable $ takeFileName fp + guard . not $ head fn == '.' + guard . not $ head fn == '#' && last fn == '#' + + lift $ do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + Text.hGetContents h + mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files - parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files + parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs new file mode 100644 index 000000000..db5957d54 --- /dev/null +++ b/src/Database/Persist/Types/Instances.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Types.Instances + ( + ) where + +import ClassyPrelude +import Database.Persist.Types + +instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where + s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal diff --git a/src/Foundation.hs b/src/Foundation.hs index 6921850cd..9161ef86a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4,7 +4,7 @@ module Foundation where -import Import.NoFoundation +import Import.NoFoundation hiding (embedFile) import qualified ClassyPrelude.Yesod as Yesod (addMessage) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -44,8 +44,9 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import qualified Data.HashSet as HashSet -import Data.List (nubBy) +import Data.List (nubBy, (!!)) import Data.Monoid (Any(..)) @@ -56,12 +57,12 @@ import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E -import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..)) +import Control.Monad.Memo.Class (MonadMemo(..), for4) import qualified Control.Monad.Catch as C import Handler.Utils.StudyFeatures @@ -78,6 +79,7 @@ import qualified Yesod.Auth.Message as Auth import qualified Data.Conduit.List as C import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Jose.Jwk as Jose import qualified Database.Memcached.Binary.IO as Memcached import Data.Bits (Bits(zeroBits)) @@ -86,6 +88,8 @@ import Network.Wai.Parse (lbsBackEnd) import qualified Data.Aeson as JSON +import Data.FileEmbed (embedFile) + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -99,6 +103,8 @@ instance DisplayAble TermId where instance DisplayAble SchoolId where display = CI.original . unSchoolKey +type SMTPPool = Pool SMTPConnection + -- infixl 9 :$: -- pattern a :$: b = a b @@ -107,24 +113,33 @@ instance DisplayAble SchoolId where -- starts running, such as database connections. Every handler will have -- access to the data present here. data UniWorX = UniWorX - { appSettings :: AppSettings + { appSettings' :: AppSettings , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool , appLdapPool :: Maybe LdapPool - , appWidgetMemcached :: Maybe Memcached.Connection + , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool , appHttpManager :: Manager , appLogger :: (ReleaseKey, TVar Logger) , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey + , appClusterID :: ClusterId , appInstanceID :: InstanceId , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) , appCronThread :: TMVar (ReleaseKey, ThreadId) , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key + , appJSONWebKeySet :: Jose.JwkSet + , appHealthReport :: TVar (Maybe (UTCTime, HealthReport)) } -type SMTPPool = Pool SMTPConnection +makeLenses_ ''UniWorX +instance HasInstanceID UniWorX InstanceId where + instanceID = _appInstanceID +instance HasJSONWebKeySet UniWorX Jose.JwkSet where + jsonWebKeySet = _appJSONWebKeySet +instance HasAppSettings UniWorX where + appSettings = _appSettings' -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -140,8 +155,10 @@ type SMTPPool = Pool SMTPConnection -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +deriving instance Generic (Route UniWorX) + -- | Convenient Type Synonyms: -type DB a = YesodDB UniWorX a +type DB = YesodDB UniWorX type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerT UniWorX IO) a @@ -151,6 +168,14 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX +pattern CMaterialR tid ssh csh mnm ptn + = CourseR tid ssh csh (MaterialR mnm ptn) + +pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX +pattern CTutorialR tid ssh csh tnm ptn + = CourseR tid ssh csh (TutorialR tnm ptn) + pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -176,8 +201,9 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- Convenience Type for Messages -type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers +-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers +type IntMaybe = Maybe Int +type TextList = [Text] -- | Convenience function for i18n messages definitions maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text @@ -190,6 +216,7 @@ mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" mkMessageVariant "UniWorX" "Button" "messages/button" "de" +mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -241,9 +268,13 @@ embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel -embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>) embedRenderMessage ''UniWorX ''EncodedSecretBoxException id embedRenderMessage ''UniWorX ''LecturerType id +embedRenderMessage ''UniWorX ''SubmissionModeDescr + $ let verbMap [_, _, "None"] = "NoSubmissions" + verbMap [_, _, v] = v <> "Submissions" + verbMap _ = error "Invalid number of verbs" + in verbMap . splitCamel newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -386,26 +417,39 @@ appLanguagesOpts = do return $ mkOptionList langOptions +instance RenderMessage UniWorX WeekDay where + renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay + +newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } + +instance RenderMessage UniWorX ShortWeekDay where + renderMessage _ ls (ShortWeekDay wDay) = pack $ map snd (wDays $ getTimeLocale' ls) !! fromEnum wDay + -- Access Control +newtype InvalidAuthTag = InvalidAuthTag Text + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Exception InvalidAuthTag + + data AccessPredicate - = APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) - | APHandler (Route UniWorX -> Bool -> Handler AuthResult) - | APDB (Route UniWorX -> Bool -> DB AuthResult) + = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) + | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult) + | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult) class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult + evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred r w = liftHandlerT $ case aPred of - (APPure p) -> runReader (p r w) <$> getMsgRenderer - (APHandler p) -> p r w - (APDB p) -> runDB $ p r w + evalAccessPred aPred aid r w = liftHandlerT $ case aPred of + (APPure p) -> runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> p aid r w + (APDB p) -> runDB $ p aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of - (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer - (APHandler p) -> lift $ p r w - (APDB p) -> p r w + evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of + (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> lift $ p aid r w + (APDB p) -> p aid r w orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -426,16 +470,57 @@ trueAR = const Authorized falseAR = Unauthorized . ($ MsgUnauthorized) . render trueAP, falseAP :: AccessPredicate -trueAP = APPure . const . const $ trueAR <$> ask -falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness +trueAP = APPure . const . const . const $ trueAR <$> ask +falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness + + +askTokenUnsafe :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadLogger m + , MonadCatch m + ) + => ExceptT AuthResult m (BearerToken (UniWorX)) +-- | This performs /no/ meaningful validation of the `BearerToken` +-- +-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead +askTokenUnsafe = $cachedHere $ do + jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt + catch (decodeToken jwt) $ \case + BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired + BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted + other -> do + $logWarnS "AuthToken" $ tshow other + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid + +validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult +validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token' + where + validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult + validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do + guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) + + User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority + guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + + authorityVal <- do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite + guardExceptT (is _Authorized authorityVal) authorityVal + + whenIsJust tokenAddAuth $ \addDNF -> do + additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite + guardExceptT (is _Authorized additionalVal) additionalVal + + return Authorized tagAccessPredicate :: AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of +tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of -- Courses: access only to school admins CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId @@ -447,13 +532,15 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of return Authorized -- other routes: access to any admin is granted here _other -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of +tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ + lift . validateToken mAuthId route isWrite =<< askTokenUnsafe +tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of AdminHijackUserR cID -> exceptT return return $ do - myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] @@ -461,21 +548,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) return Authorized r -> $unsupportedAuthPredicate AuthNoEscalation r -tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do +tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI Error MsgDeprecatedRoute - allow <- appAllowDeprecated . appSettings <$> getYesod + allow <- view _appAllowDeprecated return $ bool (Unauthorized "Deprecated Route") Authorized allow -tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do +tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("route in development: " <> tshow r) #ifdef DEVELOPMENT return Authorized #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of +tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId @@ -487,11 +574,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of return Authorized -- lecturer for any school will do _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized -tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId +tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId @@ -518,9 +605,51 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized -tagAccessPredicate AuthTime = APDB $ \route _ -> case route of +tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ tutor E.^. TutorUser E.==. E.val authId + return (course E.^. CourseId, tutorial E.^. TutorialId) + let + resMap :: Map CourseId (Set TutorialId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] + case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn + guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) + return Authorized +tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do + now <- liftIO getCurrentTime + course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn + registered <- case mAuthId of + Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid + Nothing -> return False + + if + | not registered + , maybe False (now >=) tutorialRegisterFrom + , maybe True (now <=) tutorialRegisterTo + -> return Authorized + | registered + , maybe True (now <=) tutorialDeregisterUntil + -> return Authorized + | otherwise + -> mzero + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let @@ -534,6 +663,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SFileR _ _ -> mzero SubmissionNewR -> guard active SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change SubmissionR _ _ -> guard active @@ -541,11 +671,18 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized + CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm + cTime <- liftIO getCurrentTime + let visible = NTop materialVisibleFrom <= NTop (Just cTime) + guard visible + return Authorized + CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- getBy $ TermSchoolCourseShort tid ssh csh - mAid <- lift maybeAuthId - registered <- case (mbc,mAid) of + registered <- case (mbc,mAuthId) of (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) _ -> return False case mbc of @@ -567,9 +704,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of +tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId @@ -579,8 +716,35 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized - r -> $unsupportedAuthPredicate AuthRegistered r -tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of + r -> $unsupportedAuthPredicate AuthCourseRegistered r +tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. tutorial E.^. TutorialName E.==. E.val tutn + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthTutorialRegistered r +tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do [E.Value ok] <- lift . E.select . return . E.exists $ E.from f @@ -620,16 +784,17 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialUserUser E.==. E.val participant + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - authorizedIfExists $ \(course `E.InnerJoin` tutorial) -> do + authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorial E.^. TutorialTutor E.==. E.val participant + E.where_ $ tutor E.^. TutorUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh @@ -642,14 +807,35 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r -tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of +tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] + guard $ NTop tutorialCapacity > NTop (Just registered) + return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of +tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + case (tutorialRegGroup, mAuthId) of + (Nothing, _) -> return Authorized + (_, Nothing) -> return AuthenticationRequired + (Just rGroup, Just uid) -> do + [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial + E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid + E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + guard $ not hasOther + return Authorized + r -> $unsupportedAuthPredicate AuthRegisterGroup r +tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -660,73 +846,81 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of return E.countRows return Authorized r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of +tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of +tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthRated = APDB $ \route _ -> case route of +tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of +tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == UserSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard $ is _Just submissionModeUser return Authorized r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == CorrectorSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of +tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route + referencedUser' <- decrypt referencedUser + case mAuthId of + Just uid + | uid == referencedUser' -> return Authorized + Nothing -> return AuthenticationRequired + _other -> unauthorizedI MsgUnauthorizedSelf +tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID SystemMessage{..} <- MaybeT $ get smId - isAuthenticated <- isJust <$> liftHandlerT maybeAuthId + let isAuthenticated = isJust mAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) -tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) +tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) +tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) -newtype InvalidAuthTag = InvalidAuthTag Text - deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Exception InvalidAuthTag +defaultAuthDNF :: AuthDNF +defaultAuthDNF = PredDNF $ Set.fromList + [ impureNonNull . Set.singleton $ PLVariable AuthAdmin + , impureNonNull . Set.singleton $ PLVariable AuthToken + ] -type DNF a = Set (NonNull (Set a)) - -data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -instance Universe SessionAuthTags -instance Finite SessionAuthTags -nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1) - -routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag)) +routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF -- ^ DNF up to entailment: -- -- > (A_1 && A_2 && ...) OR' B OR' ... -- -- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs +routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs where - partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag)) + partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) partition' prev t | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) = if @@ -737,47 +931,84 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p | otherwise = Left $ InvalidAuthTag t -evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite - = startEvalMemoT $ do - mr <- lift getMsgRenderer +evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite + = do + mr <- getMsgRenderer let authTagIsInactive = not . authTagIsActive - evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult - evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite + evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult + evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + where + evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do + $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') + evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' + + evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult + evalAuthLiteral PLVariable{..} = evalAuthTag plVar + evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case + Unauthorized _ -> return Authorized + AuthenticationRequired -> return AuthenticationRequired + Authorized -> unauthorizedI plVar orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR' = shortCircuitM (is _Authorized) (orAR mr) andAR' = shortCircuitM (is _Unauthorized) (andAR mr) - evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult - evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr) + evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult + evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr) - lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF + $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF - result <- evalDNF $ filter (all authTagIsActive) authDNF + result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF - unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj -> - whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do - let pivots = filter authTagIsInactive conj - whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do - lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|] - lift . tell $ Set.fromList pivots + unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj -> + whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do + let pivots = filter (authTagIsInactive . plVar) conj + whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do + let pivots' = plVar <$> pivots + $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|] + tell $ Set.fromList pivots' return result +evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor mAuthId route isWrite = do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite + +evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessForDB = evalAccessFor + evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess route isWrite = do + mAuthId <- liftHandlerT maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB = evalAccess +-- | Check whether the current user is authorized by `evalAccess` for the given route +-- Convenience function for a commonly used code fragment +hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite + +-- | Check whether the current user is authorized by `evalAccess` to read from the given route +-- Convenience function for a commonly used code fragment +hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo = flip hasAccessTo False + +-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route +-- Convenience function for a commonly used code fragment +hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo = flip hasAccessTo True + +-- | Conditional redirect that hides the URL if the user is not authorized for the route redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do -- must hide URL if not authorized @@ -798,17 +1029,17 @@ instance Yesod UniWorX where -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot approot = ApprootRequest $ \app req -> - case appRoot $ appSettings app of + case app ^. _appRoot of Nothing -> getApprootText guessApproot app req Just root -> root -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do - (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout - return . Just $ clientSessionBackend appSessionKey getCachedDate + makeSessionBackend app = do + (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout) + return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate - maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength + maximumContentLength app _ = app ^. _appMaximumContentLength -- Yesod Middleware allows you to run code before and after each handler function. -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. @@ -877,7 +1108,7 @@ instance Yesod UniWorX where encrypted :: ToJSON a => a -> Widget -> Widget encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings + shouldEncrypt <- view _appEncryptErrors if | shouldEncrypt , not canDecrypt -> do @@ -918,8 +1149,8 @@ instance Yesod UniWorX where isAuthorized = evalAccess addStaticContent ext _mime content = do - UniWorX{appWidgetMemcached, appSettings} <- getYesod - for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do + UniWorX{appWidgetMemcached, appSettings'} <- getYesod + for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do let expiry = (maybe 0 ceiling widgetMemcachedExpiry) touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn @@ -970,11 +1201,12 @@ siteLayout = siteLayout' . Just siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` -> Widget -> Handler Html siteLayout' headingOverride widget = do - master <- getYesod - let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings isModal <- hasCustomHeader HeaderIsModal + primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages + mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. @@ -1050,6 +1282,7 @@ siteLayout' headingOverride widget = do navbar = $(widgetFile "widgets/navbar/navbar") asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav/asidenav") + where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") footer :: Widget footer = $(widgetFile "widgets/footer/footer") alerts :: Widget @@ -1066,6 +1299,11 @@ siteLayout' headingOverride widget = do hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes + MsgRenderer mr <- getMsgRenderer + let + -- See Utils.Frontend.I18n and files in messages/frontend for message definitions + frontendI18n = toJSON (mr :: FrontendMessage -> Text) + pc <- widgetToPageContent $ do -- 3rd party addScript $ StaticR js_vendor_flatpickr_js @@ -1077,20 +1315,22 @@ siteLayout' headingOverride widget = do -- polyfills addScript $ StaticR js_polyfills_fetchPolyfill_js addScript $ StaticR js_polyfills_urlPolyfill_js + -- JavaScript services + addScript $ StaticR js_services_utilRegistry_js + addScript $ StaticR js_services_httpClient_js + addScript $ StaticR js_services_i18n_js -- JavaScript utils addScript $ StaticR js_utils_alerts_js 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 addScript $ StaticR js_utils_inputs_js + addScript $ StaticR js_utils_massInput_js addScript $ StaticR js_utils_modal_js - addScript $ StaticR js_utils_setup_js addScript $ StaticR js_utils_showHide_js - addScript $ StaticR js_utils_tabber_js + -- addScript $ StaticR js_utils_tabber_js addStylesheet $ StaticR css_utils_alerts_scss addStylesheet $ StaticR css_utils_asidenav_scss addStylesheet $ StaticR css_utils_asyncForm_scss @@ -1155,6 +1395,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb HelpR = return ("Hilfe" , Just HomeR) + breadcrumb HealthR = return ("Status" , Nothing) + breadcrumb InstanceR = return ("Identifikation", Nothing) + + breadcrumb ProfileR = return ("User" , Just HomeR) breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) @@ -1177,10 +1421,18 @@ instance YesodBreadcrumbs UniWorX where 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 CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR) 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) - breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) @@ -1190,6 +1442,14 @@ instance YesodBreadcrumbs UniWorX where -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads + + breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material" , Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu" , Just $ CourseR tid ssh csh MaterialListR) + breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten" , Just $ CMaterialR tid ssh csh mnm MShowR) + breadcrumb (CMaterialR tid ssh csh mnm MDelR) = return ("Löschen" , Just $ CMaterialR tid ssh csh mnm MShowR) + -- (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads + -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) @@ -1420,6 +1680,16 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] +pageActions (AdminUserR cID) = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuUserNotifications + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ UserNotificationR cID + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (InfoR) = [ MenuItem { menuItemType = PageActionPrime @@ -1440,6 +1710,26 @@ pageActions (VersionR) = [ , menuItemAccessCallback' = return True } ] +pageActions HealthR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuInstance + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InstanceR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions InstanceR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuHealth + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute HealthR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (HelpR) = [ -- MenuItem -- { menuItemType = PageActionPrime @@ -1518,6 +1808,25 @@ pageActions (CourseNewR) = [ ] pageActions (CourseR tid ssh csh CShowR) = [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR + , menuItemModal = False + , menuItemAccessCallback' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers that can create new material + materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- or show if user can see at least one of the contents + existsVisible = do + matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do + E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse + 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 + return $ material E.^. MaterialName + anyM matNames (materialAccess . E.unValue) + in runDB $ lecturerAccess `or2M` existsVisible + } + , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing @@ -1537,6 +1846,14 @@ pageActions (CourseR tid ssh csh CShowR) = } ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers , menuItemIcon = Just "user-graduate" @@ -1544,6 +1861,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseCommunication + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit @@ -1630,6 +1955,72 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh MaterialListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CMaterialR tid ssh csh mnm MShowR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CourseR tid ssh csh CTutorialListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TEditR) = + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime @@ -1789,7 +2180,7 @@ pageActions (CorrectionsR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1798,10 +2189,9 @@ pageActions (CorrectionsR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } , MenuItem { menuItemType = PageActionPrime @@ -1829,7 +2219,7 @@ pageActions (CorrectionsGradeR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1838,10 +2228,9 @@ pageActions (CorrectionsGradeR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } ] pageActions _ = [] @@ -1923,6 +2312,7 @@ pageHeading (CourseR tid ssh csh SheetNewR) = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh pageHeading (CSheetR tid ssh csh shn SShowR) = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn + -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity pageHeading (CSheetR tid ssh csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) @@ -2080,7 +2470,7 @@ instance YesodAuth UniWorX where _other -> return res $logDebugS "auth" $ tshow Creds{..} - UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod + UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do @@ -2135,6 +2525,7 @@ instance YesodAuth UniWorX where , userDownloadFiles = userDefaultDownloadFiles , userNotificationSettings = def , userMailLanguages = def + , userTokensIssuedAfter = Nothing , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -2199,7 +2590,7 @@ instance YesodAuth UniWorX where where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes + authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes [ campusLogin <$> appLdapConf <*> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin @@ -2224,22 +2615,23 @@ unsafeHandler f h = do instance YesodMail UniWorX where - defaultFromAddress = getsYesod $ appMailFrom . appSettings - mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings - mailVerp = getsYesod $ appMailVerp . appSettings + defaultFromAddress = getsYesod $ view _appMailFrom + mailObjectIdDomain = getsYesod $ view _appMailObjectDomain + mailVerp = getsYesod $ view _appMailVerp mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - void setMailObjectId + void setMailObjectIdRandom setDateCurrent - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) - ret <- mail + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData - setMailSmtpData - return ret + return mRes instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 855640144..3e5306383 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -122,7 +122,7 @@ postAdminTestR = do let emailWidget' = wrapForm emailWidget def { formAction = Just . SomeRoute $ AdminTestR , formEncoding = emailEnctype - , formAttrs = [("data-ajax-submit", "")] + , formAttrs = [("uw-async-form", "")] } @@ -166,7 +166,7 @@ postAdminTestR = do -- | 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) + -- This /needs/ to replace all occurences 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 @@ -206,7 +206,7 @@ postAdminTestR = do -- The actual call to @massInput@ is comparatively simple: - ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] @@ -287,9 +287,6 @@ instance Button UniWorX ButtonAdminStudyTerms where btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger] -- END Button needed only here -sessionKeyNewStudyTerms :: Text -sessionKeyNewStudyTerms = "key-new-study-terms" - getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR postAdminFeaturesR = do @@ -305,7 +302,7 @@ postAdminFeaturesR = do unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant let newKeys = map (StudyTermsKey' . fst) infAccepted - setSessionJson sessionKeyNewStudyTerms newKeys + setSessionJson SessionNewStudyTerms newKeys if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise @@ -323,7 +320,7 @@ postAdminFeaturesR = do Candidates.conflicts _other -> runDB Candidates.conflicts - newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms + newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable)) <- runDB $ (,,) diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 54eddd1c3..f11a76cfb 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -8,10 +8,19 @@ import Import hiding (embedFile) -- runtime dependency, and for efficiency. getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - return $ TypedContent "image/x-icon" - $ toContent $(embedFile "static/favicon.ico") +getFaviconR = do + let content = $(embedFile "static/favicon.ico") + + setEtagHashable content + + return $ TypedContent "image/x-icon" + $ toContent content getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "static/robots.txt") +getRobotsR = do + let content = $(embedFile "static/robots.txt") + + setEtagHashable content + + return $ TypedContent typePlain + $ toContent content diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 42c21d62a..4ef07e77d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -80,9 +80,6 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid -submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere -submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode - -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) @@ -131,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) -colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) +colSelect :: forall act h. (Semigroup act, 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 Sortable CorrectionTableData (DBCell m a) @@ -350,7 +347,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do - (actionRes, action) <- multiAction actions Nothing + (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 @@ -702,7 +699,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ - areq (zipFileField True) (fslI MsgCorrUploadField) Nothing + areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing case uploadRes of FormMissing -> return () @@ -724,14 +721,16 @@ postCorrectionsUploadR = do , formEncoding = uploadEncoding } - defaultLayout + + defaultLayout $ do + let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") $(widgetFile "corrections-upload") getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId - let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -740,10 +739,9 @@ postCorrectionsCreateR = do isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector E.||. isLecturer ) + E.where_ $ isCorrector E.||. isLecturer E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] - return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) + return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList opts = do opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 98016ca8e..003fdfcdc 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,11 +9,14 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Tutorial +import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete import Handler.Utils.Database import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns +import Handler.Utils.Invitations import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -23,16 +26,22 @@ import qualified Data.CaseInsensitive as CI import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -import Data.Monoid (Last(..)) - import Data.Maybe (fromJust) import qualified Data.Set as Set +import Data.Map ((!)) import qualified Data.Map as Map import qualified Database.Esqueleto as E import Text.Blaze.Html.Renderer.Text (renderHtml) +import Jobs.Queue + +import Data.Aeson hiding (Result(..)) + +import Text.Hamlet (ihamlet) + + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -271,7 +280,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors) <- 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 @@ -297,7 +306,13 @@ getCShowR tid ssh csh = do partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail) partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail) (assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff - return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants) + correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do + E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] + return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) + return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course @@ -310,6 +325,78 @@ getCShowR tid ssh csh = do , formSubmit = FormNoSubmit } registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True + + let + tutorialDBTable = DBTable{..} + where + dbtSQLQuery tutorial = do + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return tutorial + dbtRowKey = (E.^. TutorialId) + dbtProj = return + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> textCell (CI.original tutorialName) + , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do + tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) + return [whamlet| + $newline never +