Merge branch 'master' into 441-polyfills-als-npm-dependencies-einbinden
This commit is contained in:
commit
3c0fb31e51
5
.vscode/tasks.json
vendored
5
.vscode/tasks.json
vendored
@ -69,6 +69,11 @@
|
|||||||
"type": "npm",
|
"type": "npm",
|
||||||
"script": "lint",
|
"script": "lint",
|
||||||
"problemMatcher": []
|
"problemMatcher": []
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"type": "npm",
|
||||||
|
"script": "release",
|
||||||
|
"problemMatcher": []
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
91
CHANGELOG.md
91
CHANGELOG.md
@ -2,6 +2,97 @@
|
|||||||
|
|
||||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||||
|
|
||||||
|
## [5.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.4.0...v5.5.0) (2019-08-27)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **changelog:** add date ([52a88f8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/52a88f8))
|
||||||
|
* **course-applications-csv:** record rating time ([c2c6974](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2c6974))
|
||||||
|
|
||||||
|
|
||||||
|
### Features
|
||||||
|
|
||||||
|
* optional ribbon ([c2e13cf](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2e13cf))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
## [5.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.3.0...v5.4.0) (2019-08-27)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **course-edit:** only show allocation error message when relevant ([00a6ca8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/00a6ca8))
|
||||||
|
|
||||||
|
|
||||||
|
### Features
|
||||||
|
|
||||||
|
* **allocations:** serve archive of all application files by course ([5e393c5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5e393c5))
|
||||||
|
* allow editing of course applications outside of allocation ([e816a30](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e816a30))
|
||||||
|
* **course-applications:** csv transport ([cf0ec1a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf0ec1a))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
## [5.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.3...v5.3.0) (2019-08-22)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **allocations:** fix behaviour of "active" dbTable-filter ([b694a09](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b694a09))
|
||||||
|
* **course list:** show complete registration span ([754d6ca](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/754d6ca)), closes [#446](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/446)
|
||||||
|
* **home:** fix hlint and other minor bugs ([839251e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/839251e))
|
||||||
|
|
||||||
|
|
||||||
|
### Features
|
||||||
|
|
||||||
|
* **allocations:** add info page for allocations ([689b85a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/689b85a))
|
||||||
|
* **allocations:** show table of all allocations ([d621e61](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d621e61))
|
||||||
|
* **allocations:** show table of course applications ([f5da3be](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f5da3be))
|
||||||
|
* **home:** allow users to define exam warning time ([d23e222](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d23e222)), closes [#445](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/445)
|
||||||
|
* **home:** clean up homepage ([a6e2f64](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a6e2f64))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
### [5.2.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.2...v5.2.3) (2019-08-22)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **csv exam import:** ignore unchanged noshow and voided ([a346524](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a346524))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
### [5.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.1...v5.2.2) (2019-08-22)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
### [5.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.0...v5.2.1) (2019-08-21)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **csv upload exams:** allow ambiguous harmless study fields ([7d2937c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7d2937c))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
## [5.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.1.0...v5.2.0) (2019-08-21)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **csv import:** csv import preview help text adjusted ([b7321df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7321df))
|
||||||
|
* **csv import:** fix spelling and expand help text ([2c57a77](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2c57a77))
|
||||||
|
* **exam import:** inactive registered features may be selected ([3c4172c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3c4172c))
|
||||||
|
* **routes:** change ex to sheet ([9d9ead9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9d9ead9))
|
||||||
|
* **sheet list:** do not show icons for inaccessible items ([0bb9a0f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bb9a0f)), closes [#421](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/421)
|
||||||
|
|
||||||
|
|
||||||
|
### Features
|
||||||
|
|
||||||
|
* **csv import:** add explanation text ([6d0a4c1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/6d0a4c1))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
## [5.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.2...v5.1.0) (2019-08-19)
|
## [5.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.2...v5.1.0) (2019-08-19)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -119,5 +119,7 @@ user-defaults:
|
|||||||
date-format: "%d.%m.%Y"
|
date-format: "%d.%m.%Y"
|
||||||
time-format: "%R"
|
time-format: "%R"
|
||||||
download-files: false
|
download-files: false
|
||||||
|
warning-days: 1209600
|
||||||
|
|
||||||
instance-id: "_env:INSTANCE_ID:instance"
|
instance-id: "_env:INSTANCE_ID:instance"
|
||||||
|
ribbon: "_env:RIBBON:"
|
||||||
|
|||||||
@ -1,6 +1,15 @@
|
|||||||
/* GENERAL STYLES FOR FORMS */
|
/* GENERAL STYLES FOR FORMS */
|
||||||
|
|
||||||
/* FORM GROUPS */
|
/* FORM GROUPS */
|
||||||
|
.form-section-title {
|
||||||
|
color: var(--color-fontsec);
|
||||||
|
margin: 0;
|
||||||
|
|
||||||
|
+ .form-group {
|
||||||
|
margin-top: 11px;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
.form-group {
|
.form-group {
|
||||||
position: relative;
|
position: relative;
|
||||||
display: flex;
|
display: flex;
|
||||||
@ -19,15 +28,22 @@
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
.form-section-title {
|
|
||||||
color: var(--color-fontsec);
|
|
||||||
}
|
|
||||||
|
|
||||||
.form-section-legend {
|
.form-section-legend {
|
||||||
color: var(--color-fontsec);
|
color: var(--color-fontsec);
|
||||||
margin: 7px 0;
|
margin: 7px 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.form-section-title__hint {
|
||||||
|
margin-top: 7px;
|
||||||
|
color: var(--color-fontsec);
|
||||||
|
font-size: 0.9rem;
|
||||||
|
font-weight: 600;
|
||||||
|
|
||||||
|
+ .form-group {
|
||||||
|
margin-top: 11px;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
.form-group-label {
|
.form-group-label {
|
||||||
font-weight: 600;
|
font-weight: 600;
|
||||||
padding-top: 6px;
|
padding-top: 6px;
|
||||||
|
|||||||
@ -30,6 +30,7 @@ Aborted: Abgebrochen
|
|||||||
Remarks: Hinweise
|
Remarks: Hinweise
|
||||||
Registered: Angemeldet
|
Registered: Angemeldet
|
||||||
RegisteredSince: Angemeldet seit
|
RegisteredSince: Angemeldet seit
|
||||||
|
Registration: Anmeldung
|
||||||
RegisterFrom: Anmeldungen von
|
RegisterFrom: Anmeldungen von
|
||||||
RegisterTo: Anmeldungen bis
|
RegisterTo: Anmeldungen bis
|
||||||
DeRegUntil: Abmeldungen bis
|
DeRegUntil: Abmeldungen bis
|
||||||
@ -205,9 +206,12 @@ CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in U
|
|||||||
CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
|
CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
|
||||||
|
|
||||||
CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName}
|
CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName}
|
||||||
|
CourseAllApplicationsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen
|
||||||
|
CourseApplicationsAllocatedDirectory: zentral
|
||||||
|
CourseApplicationsNotAllocatedDirectory: direkt
|
||||||
|
|
||||||
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
|
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
|
||||||
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
|
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden. Ihre Änderungen wurden ignoriert.
|
||||||
|
|
||||||
|
|
||||||
CourseFormSectionRegistration: Anmeldung zum Kurs
|
CourseFormSectionRegistration: Anmeldung zum Kurs
|
||||||
@ -226,6 +230,8 @@ CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Z
|
|||||||
|
|
||||||
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
|
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
|
||||||
|
|
||||||
|
School: Institut
|
||||||
|
|
||||||
NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht.
|
NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht.
|
||||||
NoSuchSchool ssh@SchoolId: Institut #{ssh} gibt es nicht.
|
NoSuchSchool ssh@SchoolId: Institut #{ssh} gibt es nicht.
|
||||||
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
|
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
|
||||||
@ -450,7 +456,6 @@ NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen f
|
|||||||
TokensLastReset: Tokens zuletzt invalidiert
|
TokensLastReset: Tokens zuletzt invalidiert
|
||||||
TokensResetSuccess: Authorisierungs-Tokens invalidiert
|
TokensResetSuccess: Authorisierungs-Tokens invalidiert
|
||||||
|
|
||||||
HomeOpenCourses: Kurse mit offener Registrierung
|
|
||||||
HomeOpenAllocations: Offene Zentralanmeldungen
|
HomeOpenAllocations: Offene Zentralanmeldungen
|
||||||
HomeUpcomingSheets: Anstehende Übungsblätter
|
HomeUpcomingSheets: Anstehende Übungsblätter
|
||||||
HomeUpcomingExams: Bevorstehende Prüfungen
|
HomeUpcomingExams: Bevorstehende Prüfungen
|
||||||
@ -594,7 +599,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
|
|||||||
|
|
||||||
NoTableContent: Kein Tabelleninhalt
|
NoTableContent: Kein Tabelleninhalt
|
||||||
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
||||||
NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Prüfung mit offener Registrierung in Ihren Kursen
|
NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen
|
||||||
|
|
||||||
AdminHeading: Administration
|
AdminHeading: Administration
|
||||||
AdminUserHeading: Benutzeradministration
|
AdminUserHeading: Benutzeradministration
|
||||||
@ -620,6 +625,8 @@ DateFormat: Datumsformat
|
|||||||
TimeFormat: Uhrzeitformat
|
TimeFormat: Uhrzeitformat
|
||||||
DownloadFiles: Dateien automatisch herunterladen
|
DownloadFiles: Dateien automatisch herunterladen
|
||||||
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
|
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
|
||||||
|
WarningDays: Fristen-Vorschau
|
||||||
|
WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
|
||||||
NotificationSettings: Erwünschte Benachrichtigungen
|
NotificationSettings: Erwünschte Benachrichtigungen
|
||||||
FormNotifications: Benachrichtigungen
|
FormNotifications: Benachrichtigungen
|
||||||
FormBehaviour: Verhalten
|
FormBehaviour: Verhalten
|
||||||
@ -951,6 +958,8 @@ ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Dat
|
|||||||
|
|
||||||
InvalidRoute: Konnte URL nicht interpretieren
|
InvalidRoute: Konnte URL nicht interpretieren
|
||||||
|
|
||||||
|
MenuOpenCourses: Kurse mit offener Registrierung
|
||||||
|
MenuOpenAllocations: Aktive Zentralanmeldungen
|
||||||
MenuHome: Aktuell
|
MenuHome: Aktuell
|
||||||
MenuInformation: Informationen
|
MenuInformation: Informationen
|
||||||
MenuImpressum: Impressum
|
MenuImpressum: Impressum
|
||||||
@ -962,10 +971,12 @@ MenuHelp: Hilfe
|
|||||||
MenuProfile: Anpassen
|
MenuProfile: Anpassen
|
||||||
MenuLogin: Login
|
MenuLogin: Login
|
||||||
MenuLogout: Logout
|
MenuLogout: Logout
|
||||||
|
MenuAllocationList: Zentralanmeldungen
|
||||||
MenuCourseList: Kurse
|
MenuCourseList: Kurse
|
||||||
MenuCourseMembers: Kursteilnehmer
|
MenuCourseMembers: Kursteilnehmer
|
||||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||||
MenuCourseCommunication: Kursmitteilung
|
MenuCourseCommunication: Kursmitteilung
|
||||||
|
MenuCourseApplications: Bewerbungen
|
||||||
MenuTermShow: Semester
|
MenuTermShow: Semester
|
||||||
MenuSubmissionDelete: Abgabe löschen
|
MenuSubmissionDelete: Abgabe löschen
|
||||||
MenuUsers: Benutzer
|
MenuUsers: Benutzer
|
||||||
@ -1018,6 +1029,8 @@ MenuExamEdit: Bearbeiten
|
|||||||
MenuExamUsers: Teilnehmer
|
MenuExamUsers: Teilnehmer
|
||||||
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
|
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
|
||||||
MenuLecturerInvite: Dozenten hinzufügen
|
MenuLecturerInvite: Dozenten hinzufügen
|
||||||
|
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
|
||||||
|
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
|
||||||
|
|
||||||
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.
|
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
|
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||||
@ -1373,11 +1386,12 @@ BtnCsvImport: CSV-Datei importieren
|
|||||||
BtnCsvImportConfirm: CSV-Import abschließen
|
BtnCsvImportConfirm: CSV-Import abschließen
|
||||||
|
|
||||||
CsvImportNotConfigured: CSV-Import nicht vorgesehen
|
CsvImportNotConfigured: CSV-Import nicht vorgesehen
|
||||||
CsvImportConfirmationHeading: CSV-Import abschließen
|
CsvImportConfirmationHeading: CSV-Import Vorschau (noch keine Änderungen importiert)
|
||||||
CsvImportConfirmationTip: Durch den CSV-Import würden die unten aufgeführten Änderungen vorgenommen. Bitte überprüfen Sie diese zunächst sorgfältig.
|
CsvImportConfirmationTip: Es wurden noch keine Änderungen übernommen! Durch den CSV-Import könnten die unten aufgeführten Änderungen vorgenommen werden. Wählen Sie jetzt die gewünschten Änderungen aus, bevor Sie den CSV-Import abschließen.
|
||||||
CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden
|
CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden
|
||||||
CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt
|
CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt
|
||||||
CsvImportAborted: CSV-Import abgebrochen
|
CsvImportAborted: CSV-Import abgebrochen
|
||||||
|
CsvImportExplanationLabel: Hinweise zum CSV-Import
|
||||||
|
|
||||||
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
|
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
|
||||||
|
|
||||||
@ -1397,6 +1411,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer
|
|||||||
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
|
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
|
||||||
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
|
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
|
||||||
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
|
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
|
||||||
|
CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist
|
||||||
|
CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
|
||||||
|
CsvColumnApplicationsName: Voller Name des Bewerbers
|
||||||
|
CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers
|
||||||
|
CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat
|
||||||
|
CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt
|
||||||
|
CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach
|
||||||
|
CsvColumnApplicationsText: Text-Bewerbung
|
||||||
|
CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
|
||||||
|
CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
|
||||||
|
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0"
|
||||||
|
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
|
||||||
|
|
||||||
Action: Aktion
|
Action: Aktion
|
||||||
|
|
||||||
@ -1419,6 +1445,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi
|
|||||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||||
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
||||||
|
|
||||||
|
CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern
|
||||||
|
CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen
|
||||||
|
CourseApplicationsTableCsvSetRating: Bewertung eintragen
|
||||||
|
CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen
|
||||||
|
|
||||||
|
CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden
|
||||||
|
CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden
|
||||||
|
CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||||
|
|
||||||
TableHeadingFilter: Filter
|
TableHeadingFilter: Filter
|
||||||
TableHeadingCsvImport: CSV-Import
|
TableHeadingCsvImport: CSV-Import
|
||||||
TableHeadingCsvExport: CSV-Export
|
TableHeadingCsvExport: CSV-Export
|
||||||
@ -1466,6 +1501,8 @@ MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „
|
|||||||
SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
|
SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
|
||||||
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
|
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
|
||||||
|
|
||||||
|
AllocationActive: Aktiv
|
||||||
|
AllocationName: Name
|
||||||
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
|
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
|
||||||
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
|
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
|
||||||
AllocationDescription: Beschreibung
|
AllocationDescription: Beschreibung
|
||||||
@ -1473,8 +1510,11 @@ AllocationStaffRegisterFrom: Eintragung der Kurse ab
|
|||||||
AllocationStaffRegister: Eintragung der Kurse
|
AllocationStaffRegister: Eintragung der Kurse
|
||||||
AllocationRegisterFrom: Bewerbung ab
|
AllocationRegisterFrom: Bewerbung ab
|
||||||
AllocationRegister: Bewerbung
|
AllocationRegister: Bewerbung
|
||||||
|
AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
|
||||||
|
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
|
||||||
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
|
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
|
||||||
AllocationStaffAllocation: Bewertung der Bewerbungen
|
AllocationStaffAllocation: Bewerbungsbewertung
|
||||||
|
AllocationProcess: Platzvergabe
|
||||||
AllocationNoApplication: Keine Bewerbung
|
AllocationNoApplication: Keine Bewerbung
|
||||||
AllocationPriority: Priorität
|
AllocationPriority: Priorität
|
||||||
AllocationPriorityTip: Kurse, denen Sie eine höhere Priorität zuteilen, werden bei der Platzvergabe präferiert.
|
AllocationPriorityTip: Kurse, denen Sie eine höhere Priorität zuteilen, werden bei der Platzvergabe präferiert.
|
||||||
@ -1488,7 +1528,7 @@ BtnAllocationRegister: Teilnahme registrieren
|
|||||||
BtnAllocationRegistrationEdit: Teilnahme anpassen
|
BtnAllocationRegistrationEdit: Teilnahme anpassen
|
||||||
AllocationParticipation: Teilnahme an der Zentralanmeldung
|
AllocationParticipation: Teilnahme an der Zentralanmeldung
|
||||||
AllocationParticipationLoginFirst: Um an der Zentralanmeldung teilzunehmen, loggen Sie sich bitte zunächst ein.
|
AllocationParticipationLoginFirst: Um an der Zentralanmeldung teilzunehmen, loggen Sie sich bitte zunächst ein.
|
||||||
AllocationCourses: Kurse
|
AllocationCourses: Kurse dieser Zentralanmeldung
|
||||||
AllocationData: Organisatorisches
|
AllocationData: Organisatorisches
|
||||||
AllocationCoursePriority i@Natural: #{i}. Wahl
|
AllocationCoursePriority i@Natural: #{i}. Wahl
|
||||||
AllocationCourseNoApplication: Keine Bewerbung
|
AllocationCourseNoApplication: Keine Bewerbung
|
||||||
@ -1504,7 +1544,22 @@ ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zu
|
|||||||
ApplicationRatingComment: Kommentar
|
ApplicationRatingComment: Kommentar
|
||||||
ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
|
ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
|
||||||
ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
|
ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
|
||||||
|
ApplicationRatingSection: Bewertung
|
||||||
|
ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren.
|
||||||
|
|
||||||
AllocationSchoolShort: Institut
|
AllocationSchoolShort: Institut
|
||||||
Allocation: Zentralanmeldung
|
Allocation: Zentralanmeldung
|
||||||
AllocationRegisterTo: Anmeldungen bis
|
AllocationRegisterTo: Anmeldungen bis
|
||||||
|
|
||||||
|
AllocationListTitle: Zentralanmeldungen
|
||||||
|
|
||||||
|
CourseApplicationsListTitle: Bewerbungen
|
||||||
|
CourseApplicationId: Bewerbungsnummer
|
||||||
|
CourseApplicationRatingPoints: Bewertung
|
||||||
|
CourseApplicationVeto: Veto
|
||||||
|
CourseApplicationNoVeto: Kein Veto
|
||||||
|
CourseApplicationNoRatingPoints: Keine Bewertung
|
||||||
|
CourseApplicationNoRatingComment: Kein Kommentar
|
||||||
|
|
||||||
|
UserDisplayName: Voller Name
|
||||||
|
UserMatriculation: Matrikelnummer
|
||||||
@ -1,8 +1,8 @@
|
|||||||
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
|
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
|
||||||
name AllocationName
|
|
||||||
shorthand AllocationShorthand -- practical shorthand
|
|
||||||
term TermId
|
term TermId
|
||||||
school SchoolId -- school that manages this central allocation, not necessarily school of courses
|
school SchoolId -- school that manages this central allocation, not necessarily school of courses
|
||||||
|
shorthand AllocationShorthand -- practical shorthand
|
||||||
|
name AllocationName
|
||||||
description Html Maybe -- description for prospective students
|
description Html Maybe -- description for prospective students
|
||||||
staffDescription Html Maybe -- description seen by prospective lecturers only
|
staffDescription Html Maybe -- description seen by prospective lecturers only
|
||||||
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
|
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
|
||||||
@ -23,7 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
|||||||
-- overrideVisible not needed, since courses are always visible
|
-- overrideVisible not needed, since courses are always visible
|
||||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||||
deriving Show
|
deriving Show Eq Ord Generic
|
||||||
|
|
||||||
AllocationCourse
|
AllocationCourse
|
||||||
allocation AllocationId
|
allocation AllocationId
|
||||||
|
|||||||
19
models/users
19
models/users
@ -8,14 +8,14 @@
|
|||||||
-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
|
-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
|
||||||
--
|
--
|
||||||
User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
|
User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
|
||||||
|
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||||
|
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||||
|
email (CI Text) -- Case-insensitive eMail address
|
||||||
ident (CI Text) -- Case-insensitive user-identifier
|
ident (CI Text) -- Case-insensitive user-identifier
|
||||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||||
lastAuthentication UTCTime Maybe -- last login date
|
lastAuthentication UTCTime Maybe -- last login date
|
||||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
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,...)
|
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||||
email (CI Text) -- Case-insensitive eMail address
|
|
||||||
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
|
||||||
surname Text -- Display user names always through 'nameWidget displayName surname'
|
|
||||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||||
title Text Maybe -- For upcoming name customisation
|
title Text Maybe -- For upcoming name customisation
|
||||||
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
|
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
|
||||||
@ -23,12 +23,13 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
|||||||
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
|
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
|
||||||
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
|
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
|
||||||
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
|
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
|
||||||
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
|
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
|
||||||
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
|
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
|
||||||
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
|
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
|
||||||
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
|
||||||
UniqueEmail email -- Column 'email' can be used as a row-key in this table
|
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
||||||
deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory
|
UniqueEmail email -- Column 'email' can be used as a row-key in this table
|
||||||
|
deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory
|
||||||
UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user
|
UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user
|
||||||
user UserId
|
user UserId
|
||||||
school SchoolId
|
school SchoolId
|
||||||
|
|||||||
832
package-lock.json
generated
832
package-lock.json
generated
File diff suppressed because it is too large
Load Diff
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "5.1.0",
|
"version": "5.5.0",
|
||||||
"description": "",
|
"description": "",
|
||||||
"keywords": [],
|
"keywords": [],
|
||||||
"author": "",
|
"author": "",
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: uniworx
|
name: uniworx
|
||||||
version: 5.1.0
|
version: 5.5.0
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
# Due to a bug in GHC 8.0.1, we block its usage
|
# Due to a bug in GHC 8.0.1, we block its usage
|
||||||
@ -194,7 +194,7 @@ ghc-options:
|
|||||||
- -fno-warn-unrecognised-pragmas
|
- -fno-warn-unrecognised-pragmas
|
||||||
- -fno-warn-partial-type-signatures
|
- -fno-warn-partial-type-signatures
|
||||||
- -fno-max-relevant-binds
|
- -fno-max-relevant-binds
|
||||||
- -j3
|
- -j
|
||||||
|
|
||||||
when:
|
when:
|
||||||
- condition: flag(pedantic)
|
- condition: flag(pedantic)
|
||||||
|
|||||||
17
routes
17
routes
@ -61,6 +61,7 @@
|
|||||||
/info InfoR GET !free
|
/info InfoR GET !free
|
||||||
/info/lecturer InfoLecturerR GET !lecturer
|
/info/lecturer InfoLecturerR GET !lecturer
|
||||||
/info/data DataProtR GET !free
|
/info/data DataProtR GET !free
|
||||||
|
/info/allocation InfoAllocationR GET !free
|
||||||
/impressum ImpressumR GET !free
|
/impressum ImpressumR GET !free
|
||||||
/version VersionR GET !free
|
/version VersionR GET !free
|
||||||
|
|
||||||
@ -80,11 +81,11 @@
|
|||||||
/school SchoolListR GET !development
|
/school SchoolListR GET !development
|
||||||
/school/#SchoolId SchoolShowR GET !development
|
/school/#SchoolId SchoolShowR GET !development
|
||||||
|
|
||||||
|
/allocation/ AllocationListR GET !free
|
||||||
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
||||||
/ AShowR GET !free
|
/ AShowR GET !free
|
||||||
/register ARegisterR POST !time
|
/register ARegisterR POST !time
|
||||||
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
||||||
/application/#CryptoFileNameCourseApplication AApplicationR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
|
||||||
|
|
||||||
|
|
||||||
-- For Pattern Synonyms see Foundation
|
-- For Pattern Synonyms see Foundation
|
||||||
@ -106,11 +107,11 @@
|
|||||||
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
|
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
|
||||||
/subs CCorrectionsR GET POST
|
/subs CCorrectionsR GET POST
|
||||||
/subs/assigned CAssignR GET POST
|
/subs/assigned CAssignR GET POST
|
||||||
/ex SheetListR GET !course-registered !materials !corrector
|
/sheet SheetListR GET !course-registered !materials !corrector
|
||||||
/ex/new SheetNewR GET POST
|
/sheet/new SheetNewR GET POST
|
||||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
/sheet/current SheetCurrentR GET !course-registered !materials !corrector
|
||||||
/ex/unassigned SheetOldUnassignedR GET
|
/sheet/unassigned SheetOldUnassignedR GET
|
||||||
/ex/#SheetName SheetR:
|
/sheet/#SheetName SheetR:
|
||||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||||
/show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
/show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||||
/edit SEditR GET POST
|
/edit SEditR GET POST
|
||||||
@ -161,8 +162,10 @@
|
|||||||
/users/invite EInviteR GET POST
|
/users/invite EInviteR GET POST
|
||||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||||
/apps CApplicationsR GET POST
|
/apps CApplicationsR GET POST
|
||||||
|
!/apps/files CAppsFilesR GET
|
||||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||||
/files CAFilesR GET !self !lecturerANDtime
|
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
||||||
|
/files CAFilesR GET !self !lecturerANDstaff-time
|
||||||
|
|
||||||
/subs CorrectionsR GET POST !corrector !lecturer
|
/subs CorrectionsR GET POST !corrector !lecturer
|
||||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||||
|
|||||||
@ -64,10 +64,6 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
|
|||||||
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Proxy
|
|
||||||
|
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
|||||||
@ -10,7 +10,6 @@ module Auth.LDAP
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoFoundation hiding (userEmail, userDisplayName)
|
import Import.NoFoundation hiding (userEmail, userDisplayName)
|
||||||
import Control.Lens
|
|
||||||
import Network.Connection
|
import Network.Connection
|
||||||
|
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
|
|||||||
19
src/Colonnade/Instances.hs
Normal file
19
src/Colonnade/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
|
module Colonnade.Instances
|
||||||
|
(
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
|
||||||
|
import Control.Lens.Indexed (FunctorWithIndex(imap))
|
||||||
|
|
||||||
|
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
||||||
|
|
||||||
|
instance Functor h => FunctorWithIndex (Maybe a) (Colonnade h a) where
|
||||||
|
imap f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones
|
||||||
|
where
|
||||||
|
dimapColonnade' OneColonnade{..} = OneColonnade
|
||||||
|
{ oneColonnadeEncode = \x -> f (Just x) $ oneColonnadeEncode x
|
||||||
|
, oneColonnadeHead = f Nothing <$> oneColonnadeHead
|
||||||
|
}
|
||||||
28
src/Data/Bool/Instances.hs
Normal file
28
src/Data/Bool/Instances.hs
Normal file
@ -0,0 +1,28 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
|
module Data.Bool.Instances
|
||||||
|
() where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
|
||||||
|
import qualified Data.Csv as Csv
|
||||||
|
import Data.CaseInsensitive (CI)
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import Data.CaseInsensitive.Instances ()
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
|
||||||
|
instance Csv.ToField Bool where
|
||||||
|
toField True = "t"
|
||||||
|
toField False = "f"
|
||||||
|
|
||||||
|
instance Csv.FromField Bool where
|
||||||
|
parseField f = do
|
||||||
|
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
|
||||||
|
(True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool"
|
||||||
|
where
|
||||||
|
isTrue = flip elem
|
||||||
|
[ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
|
||||||
|
isFalse = flip elem
|
||||||
|
[ "no", "n", "nein", "falsch", "f", "false", "0" ]
|
||||||
@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
import Web.PathPieces
|
import Web.PathPieces
|
||||||
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
|
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
|
||||||
|
|
||||||
|
import qualified Data.Csv as Csv
|
||||||
|
|
||||||
|
|
||||||
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
|
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
|
||||||
toMarkup = toMarkup . CID.ciphertext
|
toMarkup = toMarkup . CID.ciphertext
|
||||||
@ -34,3 +36,12 @@ instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (
|
|||||||
instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
|
instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
|
||||||
toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
|
toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
|
||||||
fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
|
fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
|
||||||
|
|
||||||
|
instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
|
||||||
|
parseField = fmap CID.CryptoID . Csv.parseField
|
||||||
|
|
||||||
|
instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
|
||||||
|
toField = Csv.toField . CID.ciphertext
|
||||||
|
|
||||||
|
instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
|
||||||
|
toField = Csv.toField . CI.foldedCase . CID.ciphertext
|
||||||
|
|||||||
@ -6,17 +6,27 @@ module Data.Time.Clock.Instances
|
|||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
|
||||||
import Data.Time.Clock
|
import Database.Persist.Sql
|
||||||
|
|
||||||
|
import Data.Proxy
|
||||||
|
|
||||||
import Data.Binary (Binary)
|
import Data.Binary (Binary)
|
||||||
import qualified Data.Binary as Binary
|
import qualified Data.Binary as Binary
|
||||||
|
|
||||||
|
import Data.Time.Clock
|
||||||
import Data.Time.Calendar.Instances ()
|
import Data.Time.Calendar.Instances ()
|
||||||
|
|
||||||
|
|
||||||
instance Hashable DiffTime where
|
instance Hashable DiffTime where
|
||||||
hashWithSalt s = hashWithSalt s . toRational
|
hashWithSalt s = hashWithSalt s . toRational
|
||||||
|
|
||||||
|
instance PersistField NominalDiffTime where
|
||||||
|
toPersistValue = toPersistValue . toRational
|
||||||
|
fromPersistValue = fmap fromRational . fromPersistValue
|
||||||
|
|
||||||
|
instance PersistFieldSql NominalDiffTime where
|
||||||
|
sqlType _ = sqlType (Proxy @Rational)
|
||||||
|
|
||||||
|
|
||||||
deriving instance Generic UTCTime
|
deriving instance Generic UTCTime
|
||||||
instance Hashable UTCTime
|
instance Hashable UTCTime
|
||||||
|
|||||||
@ -18,6 +18,7 @@ module Database.Esqueleto.Utils
|
|||||||
, SqlHashable
|
, SqlHashable
|
||||||
, sha256
|
, sha256
|
||||||
, maybe
|
, maybe
|
||||||
|
, SqlProject(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
|
||||||
@ -161,21 +162,17 @@ mkExistsFilter query row criterias
|
|||||||
| otherwise = any (E.exists . query row) $ Set.toList criterias
|
| otherwise = any (E.exists . query row) $ Set.toList criterias
|
||||||
|
|
||||||
-- | Combine several filters, using logical or
|
-- | Combine several filters, using logical or
|
||||||
anyFilter :: (Foldable f)
|
anyFilter :: Foldable f
|
||||||
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
=> f (t -> cs -> E.SqlExpr (E.Value Bool))
|
||||||
-> t
|
-> (t -> cs -> E.SqlExpr (E.Value Bool))
|
||||||
-> Set.Set Text
|
|
||||||
-> E.SqlExpr (E.Value Bool)
|
|
||||||
anyFilter fltrs needle criterias = F.foldr aux false fltrs
|
anyFilter fltrs needle criterias = F.foldr aux false fltrs
|
||||||
where
|
where
|
||||||
aux fltr acc = fltr needle criterias E.||. acc
|
aux fltr acc = fltr needle criterias E.||. acc
|
||||||
|
|
||||||
-- | Combine several filters, using logical and
|
-- | Combine several filters, using logical and
|
||||||
allFilter :: (Foldable f)
|
allFilter :: Foldable f
|
||||||
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
=> f (t -> cs -> E.SqlExpr (E.Value Bool))
|
||||||
-> t
|
-> (t -> cs -> E.SqlExpr (E.Value Bool))
|
||||||
-> Set.Set Text
|
|
||||||
-> E.SqlExpr (E.Value Bool)
|
|
||||||
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
||||||
where
|
where
|
||||||
aux fltr acc = fltr needle criterias E.&&. acc
|
aux fltr acc = fltr needle criterias E.&&. acc
|
||||||
@ -232,3 +229,16 @@ maybe onNothing onJust val = E.case_
|
|||||||
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
||||||
]
|
]
|
||||||
(E.else_ onNothing)
|
(E.else_ onNothing)
|
||||||
|
|
||||||
|
|
||||||
|
class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
|
||||||
|
sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
|
||||||
|
unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
|
||||||
|
|
||||||
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
|
||||||
|
sqlProject = (E.^.)
|
||||||
|
unSqlProject _ _ = id
|
||||||
|
|
||||||
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
|
||||||
|
sqlProject = (E.?.)
|
||||||
|
unSqlProject _ _ = Just
|
||||||
|
|||||||
@ -65,7 +65,6 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
|||||||
import qualified Control.Monad.Catch as C
|
import qualified Control.Monad.Catch as C
|
||||||
|
|
||||||
import Handler.Utils.StudyFeatures
|
import Handler.Utils.StudyFeatures
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Utils.Sheet
|
import Utils.Sheet
|
||||||
import Utils.SystemMessage
|
import Utils.SystemMessage
|
||||||
@ -369,6 +368,11 @@ instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
|
|||||||
mr :: RenderMessage UniWorX msg => msg -> Text
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
||||||
mr = renderMessage foundation ls
|
mr = renderMessage foundation ls
|
||||||
|
|
||||||
|
instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
|
||||||
|
renderMessage foundation ls = either mr mr
|
||||||
|
where
|
||||||
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
||||||
|
mr = renderMessage foundation ls
|
||||||
|
|
||||||
-- ToMessage instances for converting raw numbers to Text (no internationalization)
|
-- ToMessage instances for converting raw numbers to Text (no internationalization)
|
||||||
|
|
||||||
@ -661,22 +665,6 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
|||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||||
return Authorized
|
return Authorized
|
||||||
AllocationR tid ssh ash (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do
|
|
||||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
||||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
||||||
isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
|
||||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
||||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
|
||||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
||||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
|
|
||||||
E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
|
||||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
|
||||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
|
||||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
|
||||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
|
||||||
E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId
|
|
||||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
|
||||||
return Authorized
|
|
||||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||||
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||||
@ -869,6 +857,23 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
return Authorized
|
return Authorized
|
||||||
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
||||||
|
|
||||||
|
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||||
|
Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||||
|
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||||
|
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||||
|
|
||||||
|
case allocation of
|
||||||
|
Nothing -> do
|
||||||
|
cTime <- liftIO getCurrentTime
|
||||||
|
guard $ maybe False (cTime >=) courseRegisterFrom
|
||||||
|
guard $ maybe True (cTime <=) courseRegisterTo
|
||||||
|
Just Allocation{..} -> do
|
||||||
|
cTime <- liftIO getCurrentTime
|
||||||
|
guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
|
||||||
|
guard $ NTop (Just cTime) <= NTop allocationRegisterTo
|
||||||
|
|
||||||
|
return Authorized
|
||||||
|
|
||||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
@ -887,6 +892,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
|
|
||||||
r -> $unsupportedAuthPredicate AuthTime r
|
r -> $unsupportedAuthPredicate AuthTime r
|
||||||
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
|
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
|
||||||
|
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||||
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||||
|
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||||
|
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||||
|
|
||||||
|
case allocation of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just Allocation{..} -> do
|
||||||
|
cTime <- liftIO getCurrentTime
|
||||||
|
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
||||||
|
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
||||||
|
|
||||||
|
return Authorized
|
||||||
|
|
||||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
@ -1042,6 +1061,7 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
|
|||||||
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
||||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||||
|
cTime <- liftIO getCurrentTime
|
||||||
let authorizedIfExists f = do
|
let authorizedIfExists f = do
|
||||||
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
||||||
whenExceptT ok Authorized
|
whenExceptT ok Authorized
|
||||||
@ -1102,12 +1122,16 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
|||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
-- participant is applicant for this course
|
-- participant is applicant for this course
|
||||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
|
||||||
|
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
||||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
|
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
|
||||||
|
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
|
||||||
|
|
||||||
unauthorizedI MsgUnauthorizedParticipant
|
unauthorizedI MsgUnauthorizedParticipant
|
||||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||||
@ -1194,10 +1218,6 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $
|
|||||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||||
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
||||||
return $ Right courseApplicationUser
|
return $ Right courseApplicationUser
|
||||||
AllocationR _ _ _ (AApplicationR cID) -> do
|
|
||||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
||||||
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
|
||||||
return $ Right courseApplicationUser
|
|
||||||
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
||||||
referencedUser <- case referencedUser' of
|
referencedUser <- case referencedUser' of
|
||||||
Right uid -> return uid
|
Right uid -> return uid
|
||||||
@ -1658,6 +1678,8 @@ siteLayout' headingOverride widget = do
|
|||||||
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
||||||
hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
||||||
hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
||||||
|
contentRibbon :: Maybe Widget
|
||||||
|
contentRibbon = fmap toWidget appRibbon
|
||||||
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
let
|
let
|
||||||
@ -1718,6 +1740,7 @@ instance YesodBreadcrumbs UniWorX where
|
|||||||
breadcrumb InfoR = return ("Information" , Nothing)
|
breadcrumb InfoR = return ("Information" , Nothing)
|
||||||
breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR)
|
breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR)
|
||||||
breadcrumb DataProtR = return ("Datenschutz" , Just InfoR)
|
breadcrumb DataProtR = return ("Datenschutz" , Just InfoR)
|
||||||
|
breadcrumb InfoAllocationR = return ("Zentralanmeldungen", Just InfoR)
|
||||||
breadcrumb ImpressumR = return ("Impressum" , Just InfoR)
|
breadcrumb ImpressumR = return ("Impressum" , Just InfoR)
|
||||||
breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR)
|
breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR)
|
||||||
|
|
||||||
@ -1741,11 +1764,11 @@ instance YesodBreadcrumbs UniWorX where
|
|||||||
|
|
||||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||||
|
|
||||||
|
breadcrumb AllocationListR = return ("Zentralanmeldungen", Just HomeR)
|
||||||
breadcrumb (AllocationR tid ssh ash AShowR) = do
|
breadcrumb (AllocationR tid ssh ash AShowR) = do
|
||||||
mr <- getMessageRender
|
mr <- getMessageRender
|
||||||
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR)
|
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||||
breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)
|
|
||||||
|
|
||||||
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
||||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||||
@ -1769,6 +1792,10 @@ instance YesodBreadcrumbs UniWorX where
|
|||||||
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
|
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
|
||||||
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
|
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
|
||||||
|
|
||||||
|
breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)
|
||||||
|
|
||||||
|
breadcrumb (CApplicationR tid ssh csh _ CAEditR) = return ("Bewerbung", Just $ CourseR tid ssh csh CApplicationsR)
|
||||||
|
|
||||||
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||||
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
||||||
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
||||||
@ -1963,35 +1990,19 @@ pageActions (HomeR) =
|
|||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
, MenuItem
|
, MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
, menuItemLabel = MsgAdminHeading
|
, menuItemLabel = MsgMenuOpenCourses
|
||||||
, menuItemIcon = Just "screwdriver"
|
|
||||||
, menuItemRoute = SomeRoute AdminR
|
|
||||||
, menuItemModal = False
|
|
||||||
, menuItemAccessCallback' = return True
|
|
||||||
}
|
|
||||||
, MenuItem
|
|
||||||
{ menuItemType = PageActionPrime
|
|
||||||
, menuItemLabel = MsgAdminFeaturesHeading
|
|
||||||
, menuItemIcon = Nothing
|
, menuItemIcon = Nothing
|
||||||
, menuItemRoute = SomeRoute AdminFeaturesR
|
, menuItemRoute = SomeRoute (CourseListR, [("courses-openregistration", "True")])
|
||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
, MenuItem
|
, MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
, menuItemLabel = MsgMenuMessageList
|
, menuItemLabel = MsgMenuOpenAllocations
|
||||||
, menuItemIcon = Nothing
|
, menuItemIcon = Nothing
|
||||||
, menuItemRoute = SomeRoute MessageListR
|
, menuItemRoute = SomeRoute (AllocationListR, [("allocations-active", "True")])
|
||||||
, menuItemModal = False
|
|
||||||
, menuItemAccessCallback' = return True
|
|
||||||
}
|
|
||||||
, MenuItem
|
|
||||||
{ menuItemType = PageActionPrime
|
|
||||||
, menuItemLabel = MsgMenuAdminErrMsg
|
|
||||||
, menuItemIcon = Nothing
|
|
||||||
, menuItemRoute = SomeRoute AdminErrMsgR
|
|
||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
@ -2015,20 +2026,12 @@ pageActions (AdminR) =
|
|||||||
}
|
}
|
||||||
, MenuItem
|
, MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
, menuItemLabel = MsgErrMsgHeading
|
, menuItemLabel = MsgMenuAdminErrMsg
|
||||||
, menuItemIcon = Nothing
|
, menuItemIcon = Nothing
|
||||||
, menuItemRoute = SomeRoute AdminErrMsgR
|
, menuItemRoute = SomeRoute AdminErrMsgR
|
||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
, MenuItem
|
|
||||||
{ menuItemType = PageActionPrime
|
|
||||||
, menuItemLabel = MsgMenuUsers
|
|
||||||
, menuItemIcon = Nothing
|
|
||||||
, menuItemRoute = SomeRoute UsersR
|
|
||||||
, menuItemModal = False
|
|
||||||
, menuItemAccessCallback' = return True
|
|
||||||
}
|
|
||||||
, MenuItem
|
, MenuItem
|
||||||
{ menuItemType = PageActionSecondary
|
{ menuItemType = PageActionSecondary
|
||||||
, menuItemLabel = MsgMenuAdminTest
|
, menuItemLabel = MsgMenuAdminTest
|
||||||
@ -2167,7 +2170,7 @@ pageActions (TermCourseListR tid) =
|
|||||||
]
|
]
|
||||||
pageActions (TermSchoolCourseListR _tid _ssh) =
|
pageActions (TermSchoolCourseListR _tid _ssh) =
|
||||||
[ MenuItem
|
[ MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
, menuItemLabel = MsgMenuCourseNew
|
, menuItemLabel = MsgMenuCourseNew
|
||||||
, menuItemIcon = Just "book"
|
, menuItemIcon = Just "book"
|
||||||
, menuItemRoute = SomeRoute CourseNewR
|
, menuItemRoute = SomeRoute CourseNewR
|
||||||
@ -2175,6 +2178,16 @@ pageActions (TermSchoolCourseListR _tid _ssh) =
|
|||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
|
pageActions (AllocationR _tid _ssh _ash AShowR) =
|
||||||
|
[ MenuItem
|
||||||
|
{ menuItemType = PageActionPrime
|
||||||
|
, menuItemLabel = MsgMenuAllocationInfo
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute InfoAllocationR
|
||||||
|
, menuItemModal = True
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
|
]
|
||||||
pageActions (CourseListR) =
|
pageActions (CourseListR) =
|
||||||
[ MenuItem
|
[ MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
@ -2184,6 +2197,14 @@ pageActions (CourseListR) =
|
|||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
|
, MenuItem
|
||||||
|
{ menuItemType = PageActionPrime
|
||||||
|
, menuItemLabel = MsgMenuAllocationList
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute AllocationListR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
]
|
]
|
||||||
pageActions (CourseNewR) = [
|
pageActions (CourseNewR) = [
|
||||||
MenuItem
|
MenuItem
|
||||||
@ -2262,6 +2283,28 @@ pageActions (CourseR tid ssh csh CShowR) =
|
|||||||
anyM examNames $ examAccess . E.unValue
|
anyM examNames $ examAccess . E.unValue
|
||||||
in runDB $ lecturerAccess `or2M` existsVisible
|
in runDB $ lecturerAccess `or2M` existsVisible
|
||||||
}
|
}
|
||||||
|
, MenuItem
|
||||||
|
{ menuItemType = PageActionSecondary
|
||||||
|
, menuItemLabel = MsgMenuCourseApplications
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' =
|
||||||
|
let courseWhere course = course <$ do
|
||||||
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||||
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
|
existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||||
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||||
|
void $ courseWhere course
|
||||||
|
courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
|
||||||
|
void $ courseWhere course
|
||||||
|
return $ course E.^. CourseApplicationsRequired
|
||||||
|
courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
||||||
|
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||||
|
void $ courseWhere course
|
||||||
|
in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
|
||||||
|
}
|
||||||
, MenuItem
|
, MenuItem
|
||||||
{ menuItemType = PageActionSecondary
|
{ menuItemType = PageActionSecondary
|
||||||
, menuItemLabel = MsgMenuCourseMembers
|
, menuItemLabel = MsgMenuCourseMembers
|
||||||
@ -2678,6 +2721,28 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
|
|||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
|
pageActions (CourseR tid ssh csh CApplicationsR) =
|
||||||
|
[ MenuItem
|
||||||
|
{ menuItemType = PageActionPrime
|
||||||
|
, menuItemLabel = MsgMenuCourseApplicationsFiles
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback'
|
||||||
|
= let appAccess (E.Value appId) = do
|
||||||
|
cID <- encrypt appId
|
||||||
|
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||||
|
appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||||
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||||
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||||
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
|
E.where_ . E.exists . E.from $ \courseApplicationFile ->
|
||||||
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
|
||||||
|
return $ courseApplication E.^. CourseApplicationId
|
||||||
|
in runDB . runConduit $ appSource .| anyMC appAccess
|
||||||
|
}
|
||||||
|
]
|
||||||
pageActions (CorrectionsR) =
|
pageActions (CorrectionsR) =
|
||||||
[ MenuItem
|
[ MenuItem
|
||||||
{ menuItemType = PageActionPrime
|
{ menuItemType = PageActionPrime
|
||||||
@ -3028,6 +3093,7 @@ upsertCampusUser ldapData Creds{..} = do
|
|||||||
, userDateFormat = userDefaultDateFormat
|
, userDateFormat = userDefaultDateFormat
|
||||||
, userTimeFormat = userDefaultTimeFormat
|
, userTimeFormat = userDefaultTimeFormat
|
||||||
, userDownloadFiles = userDefaultDownloadFiles
|
, userDownloadFiles = userDefaultDownloadFiles
|
||||||
|
, userWarningDays = userDefaultWarningDays
|
||||||
, userNotificationSettings = def
|
, userNotificationSettings = def
|
||||||
, userMailLanguages = def
|
, userMailLanguages = def
|
||||||
, userTokensIssuedAfter = Nothing
|
, userTokensIssuedAfter = Nothing
|
||||||
|
|||||||
@ -8,8 +8,6 @@ import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
|||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Writer (mapWriterT)
|
import Control.Monad.Trans.Writer (mapWriterT)
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
-- import Data.Time
|
-- import Data.Time
|
||||||
import Data.Char (isDigit)
|
import Data.Char (isDigit)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|||||||
@ -2,6 +2,8 @@ module Handler.Allocation
|
|||||||
( module Handler.Allocation
|
( module Handler.Allocation
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Handler.Allocation.Info as Handler.Allocation
|
||||||
import Handler.Allocation.Show as Handler.Allocation
|
import Handler.Allocation.Show as Handler.Allocation
|
||||||
import Handler.Allocation.Application as Handler.Allocation
|
import Handler.Allocation.Application as Handler.Allocation
|
||||||
import Handler.Allocation.Register as Handler.Allocation
|
import Handler.Allocation.Register as Handler.Allocation
|
||||||
|
import Handler.Allocation.List as Handler.Allocation
|
||||||
|
|||||||
@ -4,16 +4,13 @@ module Handler.Allocation.Application
|
|||||||
, ApplicationForm(..)
|
, ApplicationForm(..)
|
||||||
, ApplicationFormMode(..)
|
, ApplicationFormMode(..)
|
||||||
, ApplicationFormException(..)
|
, ApplicationFormException(..)
|
||||||
, applicationForm
|
, applicationForm, editApplicationR
|
||||||
, postAApplyR
|
, postAApplyR
|
||||||
, getAApplicationR, postAApplicationR
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import hiding (hash)
|
import Import hiding (hash)
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
@ -73,20 +70,21 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
|
|||||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
instance Exception ApplicationFormException
|
instance Exception ApplicationFormException
|
||||||
|
|
||||||
applicationForm :: AllocationId
|
applicationForm :: (Maybe AllocationId)
|
||||||
-> CourseId
|
-> CourseId
|
||||||
-> UserId
|
-> UserId
|
||||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||||
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||||
applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
|
||||||
|
|
||||||
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
|
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
|
||||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||||
coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId]
|
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||||
course <- getJust cid
|
course <- getJust cid
|
||||||
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
|
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
|
||||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||||
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||||
return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
|
return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
|
||||||
return (mApplication, coursesNum, course, maxPrio)
|
return (mApplication, coursesNum, course, maxPrio)
|
||||||
@ -112,18 +110,20 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
|||||||
}
|
}
|
||||||
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
|
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
|
||||||
|
|
||||||
(prioRes, prioView) <- case (afmApplicant, afmApplicantEdit, mApp) of
|
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||||
(True , True , Nothing)
|
(True , True , True , Nothing)
|
||||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
||||||
(True , True , Just _ )
|
(True , True , True , Just _ )
|
||||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||||
(True , False, _ )
|
(True , True , False, _ )
|
||||||
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
|
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
|
||||||
(False, _ , Just _ )
|
(True , False, _ , Just _ )
|
||||||
| is _Just oldPrio
|
| is _Just oldPrio
|
||||||
-> pure (FormSuccess oldPrio, Nothing)
|
-> pure (FormSuccess oldPrio, Nothing)
|
||||||
_other
|
(True , _ , _ , _ )
|
||||||
-> throwM ApplicationFormNoApplication
|
-> throwM ApplicationFormNoApplication
|
||||||
|
(False, _ , _ , _ )
|
||||||
|
-> pure (FormSuccess Nothing, Nothing)
|
||||||
|
|
||||||
(fieldRes, fieldView') <- if
|
(fieldRes, fieldView') <- if
|
||||||
| afmApplicantEdit || afmLecturer
|
| afmApplicantEdit || afmLecturer
|
||||||
@ -212,6 +212,15 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
|||||||
]
|
]
|
||||||
(actionRes, buttonsView) <- buttonForm' buttons csrf
|
(actionRes, buttonsView) <- buttonForm' buttons csrf
|
||||||
|
|
||||||
|
ratingSection <- if
|
||||||
|
| afmLecturer
|
||||||
|
, afmApplicantEdit
|
||||||
|
-> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection
|
||||||
|
| afmLecturer
|
||||||
|
-> Just . snd <$> formSection MsgApplicationRatingSection
|
||||||
|
| otherwise
|
||||||
|
-> return Nothing
|
||||||
|
|
||||||
return ( ApplicationForm
|
return ( ApplicationForm
|
||||||
<$> prioRes
|
<$> prioRes
|
||||||
<*> fieldRes
|
<*> fieldRes
|
||||||
@ -229,7 +238,8 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
|||||||
, filesLinkView
|
, filesLinkView
|
||||||
, filesWarningView
|
, filesWarningView
|
||||||
] ++ maybe [] (map Just) filesView ++
|
] ++ maybe [] (map Just) filesView ++
|
||||||
[ vetoView
|
[ ratingSection
|
||||||
|
, vetoView
|
||||||
, pointsView
|
, pointsView
|
||||||
, commentView
|
, commentView
|
||||||
]
|
]
|
||||||
@ -240,7 +250,7 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
editApplicationR :: AllocationId
|
editApplicationR :: Maybe AllocationId
|
||||||
-> UserId
|
-> UserId
|
||||||
-> CourseId
|
-> CourseId
|
||||||
-> Maybe CourseApplicationId
|
-> Maybe CourseApplicationId
|
||||||
@ -248,10 +258,10 @@ editApplicationR :: AllocationId
|
|||||||
-> (AllocationApplicationButton -> Bool)
|
-> (AllocationApplicationButton -> Bool)
|
||||||
-> SomeRoute UniWorX
|
-> SomeRoute UniWorX
|
||||||
-> Handler (ApplicationFormView, Enctype)
|
-> Handler (ApplicationFormView, Enctype)
|
||||||
editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||||
Course{..} <- runDB $ get404 cid
|
Course{..} <- runDB $ get404 cid
|
||||||
|
|
||||||
((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode
|
((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode
|
||||||
|
|
||||||
formResult appRes $ \ApplicationForm{..} -> do
|
formResult appRes $ \ApplicationForm{..} -> do
|
||||||
if
|
if
|
||||||
@ -260,7 +270,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
|||||||
-> runDB $ do
|
-> runDB $ do
|
||||||
haveOld <- exists [ CourseApplicationCourse ==. cid
|
haveOld <- exists [ CourseApplicationCourse ==. cid
|
||||||
, CourseApplicationUser ==. uid
|
, CourseApplicationUser ==. uid
|
||||||
, CourseApplicationAllocation ==. Just aId
|
, CourseApplicationAllocation ==. maId
|
||||||
]
|
]
|
||||||
when haveOld $
|
when haveOld $
|
||||||
invalidArgsI [MsgCourseApplicationExists]
|
invalidArgsI [MsgCourseApplicationExists]
|
||||||
@ -276,7 +286,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
|||||||
, courseApplicationRatingVeto = afRatingVeto
|
, courseApplicationRatingVeto = afRatingVeto
|
||||||
, courseApplicationRatingPoints = afRatingPoints
|
, courseApplicationRatingPoints = afRatingPoints
|
||||||
, courseApplicationRatingComment = afRatingComment
|
, courseApplicationRatingComment = afRatingComment
|
||||||
, courseApplicationAllocation = Just aId
|
, courseApplicationAllocation = maId
|
||||||
, courseApplicationAllocationPriority = afPriority
|
, courseApplicationAllocationPriority = afPriority
|
||||||
, courseApplicationTime = now
|
, courseApplicationTime = now
|
||||||
, courseApplicationRatingTime = guardOn rated now
|
, courseApplicationRatingTime = guardOn rated now
|
||||||
@ -330,7 +340,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
|||||||
, courseApplicationRatingVeto = afRatingVeto
|
, courseApplicationRatingVeto = afRatingVeto
|
||||||
, courseApplicationRatingPoints = afRatingPoints
|
, courseApplicationRatingPoints = afRatingPoints
|
||||||
, courseApplicationRatingComment = afRatingComment
|
, courseApplicationRatingComment = afRatingComment
|
||||||
, courseApplicationAllocation = Just aId
|
, courseApplicationAllocation = maId
|
||||||
, courseApplicationAllocationPriority = afPriority
|
, courseApplicationAllocationPriority = afPriority
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -395,50 +405,6 @@ postAApplyR tid ssh ash cID = do
|
|||||||
, afmLecturer
|
, afmLecturer
|
||||||
}
|
}
|
||||||
|
|
||||||
void . editApplicationR aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
|
void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
|
||||||
|
|
||||||
invalidArgs ["Application form required"]
|
invalidArgs ["Application form required"]
|
||||||
|
|
||||||
|
|
||||||
getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html
|
|
||||||
getAApplicationR = postAApplicationR
|
|
||||||
postAApplicationR tid ssh ash cID = do
|
|
||||||
uid <- requireAuthId
|
|
||||||
appId <- decrypt cID
|
|
||||||
(Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
|
|
||||||
alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
||||||
app <- get404 appId
|
|
||||||
Just course <- getEntity $ courseApplicationCourse app
|
|
||||||
Just appUser <- get $ courseApplicationUser app
|
|
||||||
isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
|
|
||||||
return (alloc, course, app, isAdmin, appUser)
|
|
||||||
|
|
||||||
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
|
||||||
afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID
|
|
||||||
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
|
|
||||||
|
|
||||||
let afMode = ApplicationFormMode
|
|
||||||
{ afmApplicant = uid == courseApplicationUser || isAdmin
|
|
||||||
, afmApplicantEdit
|
|
||||||
, afmLecturer
|
|
||||||
}
|
|
||||||
|
|
||||||
(ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
|
||||||
| uid == courseApplicationUser
|
|
||||||
-> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID
|
|
||||||
| otherwise
|
|
||||||
-> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
|
|
||||||
|
|
||||||
let title = MsgCourseApplicationTitle userDisplayName courseShorthand
|
|
||||||
|
|
||||||
siteLayoutMsg title $ do
|
|
||||||
setTitleI title
|
|
||||||
|
|
||||||
wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
|
|
||||||
{ formMethod = POST
|
|
||||||
, formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
|
|
||||||
, formEncoding = appEnc
|
|
||||||
, formAttrs = []
|
|
||||||
, formSubmit = FormNoSubmit
|
|
||||||
, formAnchor = Nothing :: Maybe Text
|
|
||||||
}
|
|
||||||
|
|||||||
13
src/Handler/Allocation/Info.hs
Normal file
13
src/Handler/Allocation/Info.hs
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
module Handler.Allocation.Info
|
||||||
|
( getInfoAllocationR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
|
|
||||||
|
|
||||||
|
getInfoAllocationR :: Handler Html
|
||||||
|
getInfoAllocationR =
|
||||||
|
siteLayoutMsg MsgMenuAllocationInfo $ do
|
||||||
|
setTitleI MsgMenuAllocationInfo
|
||||||
|
$(i18nWidgetFile "allocation-info")
|
||||||
89
src/Handler/Allocation/List.hs
Normal file
89
src/Handler/Allocation/List.hs
Normal file
@ -0,0 +1,89 @@
|
|||||||
|
module Handler.Allocation.List
|
||||||
|
( getAllocationListR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import Handler.Utils.Table.Columns
|
||||||
|
import Handler.Utils.Table.Pagination
|
||||||
|
|
||||||
|
|
||||||
|
type AllocationTableExpr = E.SqlExpr (Entity Allocation)
|
||||||
|
type AllocationTableData = DBRow (Entity Allocation)
|
||||||
|
|
||||||
|
allocationListIdent :: Text
|
||||||
|
allocationListIdent = "allocations"
|
||||||
|
|
||||||
|
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
|
||||||
|
queryAllocation = id
|
||||||
|
|
||||||
|
resultAllocation :: Lens' AllocationTableData (Entity Allocation)
|
||||||
|
resultAllocation = _dbrOutput
|
||||||
|
|
||||||
|
allocationTermLink :: TermId -> SomeRoute UniWorX
|
||||||
|
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
|
||||||
|
|
||||||
|
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
|
||||||
|
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
|
||||||
|
|
||||||
|
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||||
|
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||||
|
|
||||||
|
getAllocationListR :: Handler Html
|
||||||
|
getAllocationListR = do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
let
|
||||||
|
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
|
||||||
|
dbtSQLQuery = return
|
||||||
|
|
||||||
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
|
||||||
|
dbtProj = return
|
||||||
|
|
||||||
|
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
|
||||||
|
|
||||||
|
dbtColonnade :: Colonnade Sortable _ _
|
||||||
|
dbtColonnade = mconcat
|
||||||
|
[ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
|
||||||
|
, anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
|
||||||
|
, anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtSorting = mconcat
|
||||||
|
[ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
|
||||||
|
, sortSchool $ queryAllocation . to (E.^. AllocationSchool)
|
||||||
|
, sortAllocationName $ queryAllocation . to (E.^. AllocationName)
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtFilter = mconcat
|
||||||
|
[ fltrAllocationActive now queryAllocation
|
||||||
|
, fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
|
||||||
|
, fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
|
||||||
|
, fltrAllocation queryAllocation
|
||||||
|
]
|
||||||
|
dbtFilterUI = mconcat
|
||||||
|
[ fltrAllocationActiveUI
|
||||||
|
, fltrTermUI
|
||||||
|
, fltrSchoolUI
|
||||||
|
, fltrAllocationUI
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtStyle = def
|
||||||
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||||
|
}
|
||||||
|
dbtParams = def
|
||||||
|
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
|
||||||
|
dbtIdent = allocationListIdent
|
||||||
|
|
||||||
|
psValidator :: PSValidator _ _
|
||||||
|
psValidator = def
|
||||||
|
& defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "allocation"]
|
||||||
|
|
||||||
|
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
||||||
|
|
||||||
|
siteLayoutMsg MsgAllocationListTitle $ do
|
||||||
|
setTitleI MsgAllocationListTitle
|
||||||
|
table
|
||||||
@ -8,8 +8,6 @@ module Handler.Allocation.Register
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Handler.Utils.Form
|
import Handler.Utils.Form
|
||||||
|
|
||||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Handler.Allocation.Show
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Handler.Allocation.Register
|
import Handler.Allocation.Register
|
||||||
import Handler.Allocation.Application
|
import Handler.Allocation.Application
|
||||||
@ -15,6 +14,7 @@ import qualified Database.Esqueleto as E
|
|||||||
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||||
getAShowR tid ssh ash = do
|
getAShowR tid ssh ash = do
|
||||||
muid <- maybeAuthId
|
muid <- maybeAuthId
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
|
||||||
let
|
let
|
||||||
resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course)
|
resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course)
|
||||||
@ -71,15 +71,17 @@ getAShowR tid ssh ash = do
|
|||||||
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
|
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
|
||||||
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
||||||
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||||
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer
|
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
|
||||||
subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId
|
tRoute <- case mApp of
|
||||||
|
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
||||||
|
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||||
let mApplyFormView' = view _1 <$> mApplyFormView
|
let mApplyFormView' = view _1 <$> mApplyFormView
|
||||||
overrideVisible = not mayApply && is _Just mApp
|
overrideVisible = not mayApply && is _Just mApp
|
||||||
case mApplyFormView of
|
case mApplyFormView of
|
||||||
Just (_, appFormEnctype)
|
Just (_, appFormEnctype)
|
||||||
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
|
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
|
||||||
{ formMethod = POST
|
{ formMethod = POST
|
||||||
, formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute
|
, formAction = Just $ SomeRoute tRoute
|
||||||
, formEncoding = appFormEnctype
|
, formEncoding = appFormEnctype
|
||||||
, formAttrs = [ ("class", "allocation-course")
|
, formAttrs = [ ("class", "allocation-course")
|
||||||
]
|
]
|
||||||
@ -92,5 +94,6 @@ getAShowR tid ssh ash = do
|
|||||||
<div .allocation-course ##{toPathPiece cID}>
|
<div .allocation-course ##{toPathPiece cID}>
|
||||||
^{wdgt}
|
^{wdgt}
|
||||||
|]
|
|]
|
||||||
|
let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
|
||||||
|
allocationInfoModal = modal [whamlet|_{MsgMenuAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
|
||||||
$(widgetFile "allocation/show")
|
$(widgetFile "allocation/show")
|
||||||
|
|||||||
@ -12,8 +12,6 @@ import Handler.Utils.SheetType
|
|||||||
import Handler.Utils.Delete
|
import Handler.Utils.Delete
|
||||||
-- import Handler.Utils.Zip
|
-- import Handler.Utils.Zip
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.List as List (nub, foldl, foldr)
|
import Data.List as List (nub, foldl, foldr)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|||||||
@ -1,42 +1,7 @@
|
|||||||
module Handler.Course.Application
|
module Handler.Course.Application
|
||||||
( getCAFilesR
|
( module Handler.Course.Application
|
||||||
, getCApplicationsR, postCApplicationsR
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Handler.Course.Application.List as Handler.Course.Application
|
||||||
|
import Handler.Course.Application.Files as Handler.Course.Application
|
||||||
import Handler.Utils
|
import Handler.Course.Application.Edit as Handler.Course.Application
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
|
||||||
|
|
||||||
import System.FilePath (addExtension)
|
|
||||||
|
|
||||||
import qualified Data.Conduit.List as C
|
|
||||||
|
|
||||||
|
|
||||||
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
|
||||||
getCAFilesR tid ssh csh cID = do
|
|
||||||
appId <- decrypt cID
|
|
||||||
User{..} <- runDB $ do
|
|
||||||
CourseApplication{..} <- get404 appId
|
|
||||||
Course{..} <- get404 courseApplicationCourse
|
|
||||||
let matches = and
|
|
||||||
[ tid == courseTerm
|
|
||||||
, ssh == courseSchool
|
|
||||||
, csh == courseShorthand
|
|
||||||
]
|
|
||||||
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
|
||||||
get404 courseApplicationUser
|
|
||||||
|
|
||||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
|
||||||
let
|
|
||||||
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
|
||||||
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
|
||||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
|
||||||
return file
|
|
||||||
|
|
||||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
|
||||||
|
|
||||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
||||||
getCApplicationsR = postCApplicationsR
|
|
||||||
postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications
|
|
||||||
|
|||||||
55
src/Handler/Course/Application/Edit.hs
Normal file
55
src/Handler/Course/Application/Edit.hs
Normal file
@ -0,0 +1,55 @@
|
|||||||
|
module Handler.Course.Application.Edit
|
||||||
|
( getCAEditR, postCAEditR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import Handler.Utils
|
||||||
|
import Handler.Allocation.Application
|
||||||
|
|
||||||
|
|
||||||
|
getCAEditR, postCAEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler Html
|
||||||
|
getCAEditR = postCAEditR
|
||||||
|
postCAEditR tid ssh csh cID = do
|
||||||
|
uid <- requireAuthId
|
||||||
|
appId <- decrypt cID
|
||||||
|
(mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
|
||||||
|
course <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
app <- get404 appId
|
||||||
|
mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
|
||||||
|
appUser <- get404 $ courseApplicationUser app
|
||||||
|
isAdmin <- case mAlloc of
|
||||||
|
Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
|
||||||
|
Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool]
|
||||||
|
return (mAlloc, course, app, isAdmin, appUser)
|
||||||
|
|
||||||
|
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||||
|
afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||||
|
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||||
|
|
||||||
|
let afMode = ApplicationFormMode
|
||||||
|
{ afmApplicant = uid == courseApplicationUser || isAdmin
|
||||||
|
, afmApplicantEdit
|
||||||
|
, afmLecturer
|
||||||
|
}
|
||||||
|
|
||||||
|
(ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
||||||
|
| uid == courseApplicationUser
|
||||||
|
, Just (Entity _ Allocation{..}) <- mAlloc
|
||||||
|
-> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID
|
||||||
|
| otherwise
|
||||||
|
-> SomeRoute $ CApplicationR tid ssh csh cID CAEditR
|
||||||
|
|
||||||
|
let title = MsgCourseApplicationTitle userDisplayName courseShorthand
|
||||||
|
|
||||||
|
siteLayoutMsg title $ do
|
||||||
|
setTitleI title
|
||||||
|
|
||||||
|
wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
|
||||||
|
{ formMethod = POST
|
||||||
|
, formAction = Just . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
|
||||||
|
, formEncoding = appEnc
|
||||||
|
, formAttrs = []
|
||||||
|
, formSubmit = FormNoSubmit
|
||||||
|
, formAnchor = Nothing :: Maybe Text
|
||||||
|
}
|
||||||
108
src/Handler/Course/Application/Files.hs
Normal file
108
src/Handler/Course/Application/Files.hs
Normal file
@ -0,0 +1,108 @@
|
|||||||
|
module Handler.Course.Application.Files
|
||||||
|
( getCAFilesR
|
||||||
|
, getCAppsFilesR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
|
|
||||||
|
import System.FilePath (addExtension, (</>))
|
||||||
|
|
||||||
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
|
||||||
|
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
||||||
|
getCAFilesR tid ssh csh cID = do
|
||||||
|
appId <- decrypt cID
|
||||||
|
User{..} <- runDB $ do
|
||||||
|
CourseApplication{..} <- get404 appId
|
||||||
|
Course{..} <- get404 courseApplicationCourse
|
||||||
|
let matches = and
|
||||||
|
[ tid == courseTerm
|
||||||
|
, ssh == courseSchool
|
||||||
|
, csh == courseShorthand
|
||||||
|
]
|
||||||
|
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
||||||
|
get404 courseApplicationUser
|
||||||
|
|
||||||
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
||||||
|
let
|
||||||
|
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
||||||
|
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
||||||
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||||
|
return file
|
||||||
|
|
||||||
|
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||||
|
|
||||||
|
|
||||||
|
getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||||
|
getCAppsFilesR tid ssh csh = do
|
||||||
|
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
|
||||||
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
|
||||||
|
|
||||||
|
let
|
||||||
|
fsSource :: Source DB File
|
||||||
|
fsSource = do
|
||||||
|
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
|
||||||
|
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
||||||
|
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||||
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||||
|
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 (allocation, user, courseApplication)
|
||||||
|
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
|
||||||
|
cID <- cachedByBinary appId $ encrypt appId
|
||||||
|
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||||
|
let
|
||||||
|
applicationAllocs = setOf (folded . _1) apps'
|
||||||
|
|
||||||
|
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
|
||||||
|
|
||||||
|
allEqualOn :: Eq x => Getter _ x -> Bool
|
||||||
|
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
|
||||||
|
|
||||||
|
mkAllocationDir mbAlloc
|
||||||
|
| not $ allEqualOn _1
|
||||||
|
, Just Allocation{..} <- mbAlloc
|
||||||
|
= (</>) $ unpack [st|#{CI.foldCase (termToText (unTermKey allocationTerm))}-#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
||||||
|
| not $ allEqualOn _2
|
||||||
|
, Just Allocation{..} <- mbAlloc
|
||||||
|
= (</>) $ unpack [st|#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
||||||
|
| not $ allEqualOn _3
|
||||||
|
, Just Allocation{..} <- mbAlloc
|
||||||
|
= (</>) . unpack $ CI.foldedCase allocationShorthand
|
||||||
|
| Just Allocation{} <- mbAlloc
|
||||||
|
, not $ all (is _Just) applicationAllocs
|
||||||
|
= (</>) . unpack $ mr MsgCourseApplicationsAllocatedDirectory
|
||||||
|
| Nothing <- mbAlloc
|
||||||
|
, any (is _Just) applicationAllocs
|
||||||
|
= (</>) . unpack $ mr MsgCourseApplicationsNotAllocatedDirectory
|
||||||
|
| otherwise
|
||||||
|
= id
|
||||||
|
|
||||||
|
forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
|
||||||
|
cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
|
||||||
|
let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
|
||||||
|
dirFiles = C.map $ over _fileTitle mkAppDir . entityVal
|
||||||
|
fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
||||||
|
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
||||||
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||||
|
return file
|
||||||
|
|
||||||
|
yield File
|
||||||
|
{ fileModified = courseApplicationTime
|
||||||
|
, fileTitle = mkAppDir ""
|
||||||
|
, fileContent = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
fileEntitySource .| dirFiles
|
||||||
|
|
||||||
|
|
||||||
|
serveSomeFiles archiveName fsSource
|
||||||
535
src/Handler/Course/Application/List.hs
Normal file
535
src/Handler/Course/Application/List.hs
Normal file
@ -0,0 +1,535 @@
|
|||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Handler.Course.Application.List
|
||||||
|
( getCApplicationsR, postCApplicationsR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import Handler.Utils
|
||||||
|
import Handler.Utils.Table.Columns
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
|
import qualified Data.Csv as Csv
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Data.Text.Lens as Text
|
||||||
|
|
||||||
|
import Data.CaseInsensitive (CI)
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
|
|
||||||
|
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||||
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||||
|
)
|
||||||
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||||
|
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||||
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||||
|
)
|
||||||
|
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||||
|
, Entity User
|
||||||
|
, E.Value Bool -- hasFiles
|
||||||
|
, Maybe (Entity Allocation)
|
||||||
|
, Maybe (Entity StudyFeatures)
|
||||||
|
, Maybe (Entity StudyTerms)
|
||||||
|
, Maybe (Entity StudyDegree)
|
||||||
|
)
|
||||||
|
|
||||||
|
courseApplicationsIdent :: Text
|
||||||
|
courseApplicationsIdent = "applications"
|
||||||
|
|
||||||
|
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||||
|
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||||
|
|
||||||
|
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||||
|
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||||
|
|
||||||
|
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||||
|
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||||
|
where
|
||||||
|
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||||
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||||
|
|
||||||
|
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||||
|
queryAllocation = to $(sqlLOJproj 3 2)
|
||||||
|
|
||||||
|
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||||
|
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||||
|
|
||||||
|
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||||
|
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||||
|
|
||||||
|
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||||
|
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||||
|
|
||||||
|
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||||
|
resultCourseApplication = _dbrOutput . _1
|
||||||
|
|
||||||
|
resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||||
|
resultUser = _dbrOutput . _2
|
||||||
|
|
||||||
|
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||||
|
resultHasFiles = _dbrOutput . _3 . _Value
|
||||||
|
|
||||||
|
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||||
|
resultAllocation = _dbrOutput . _4 . _Just
|
||||||
|
|
||||||
|
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||||
|
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||||
|
|
||||||
|
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||||
|
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||||
|
|
||||||
|
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||||
|
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||||
|
|
||||||
|
|
||||||
|
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
|
||||||
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
|
deriving newtype (Enum, Bounded)
|
||||||
|
makePrisms ''CourseApplicationsTableVeto
|
||||||
|
|
||||||
|
instance Csv.ToField CourseApplicationsTableVeto where
|
||||||
|
toField (CourseApplicationsTableVeto True) = "veto"
|
||||||
|
toField (CourseApplicationsTableVeto False) = ""
|
||||||
|
|
||||||
|
instance Csv.FromField CourseApplicationsTableVeto where
|
||||||
|
parseField f = do
|
||||||
|
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
|
||||||
|
return . CourseApplicationsTableVeto $ any (== t)
|
||||||
|
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
|
||||||
|
|
||||||
|
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
|
||||||
|
{ csvCAAllocation :: Maybe AllocationShorthand
|
||||||
|
, csvCAApplication :: Maybe CryptoFileNameCourseApplication
|
||||||
|
, csvCAName :: Maybe Text
|
||||||
|
, csvCAMatriculation :: Maybe Text
|
||||||
|
, csvCAField :: Maybe Text
|
||||||
|
, csvCADegree :: Maybe Text
|
||||||
|
, csvCASemester :: Maybe Int
|
||||||
|
, csvCAText :: Maybe Text
|
||||||
|
, csvCAHasFiles :: Maybe Bool
|
||||||
|
, csvCAVeto :: Maybe CourseApplicationsTableVeto
|
||||||
|
, csvCARating :: Maybe ExamGrade
|
||||||
|
, csvCAComment :: Maybe Text
|
||||||
|
} deriving (Generic)
|
||||||
|
makeLenses_ ''CourseApplicationsTableCsv
|
||||||
|
|
||||||
|
courseApplicationsTableCsvOptions :: Csv.Options
|
||||||
|
courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
|
||||||
|
|
||||||
|
instance Csv.ToNamedRecord CourseApplicationsTableCsv where
|
||||||
|
toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions
|
||||||
|
|
||||||
|
instance Csv.FromNamedRecord CourseApplicationsTableCsv where
|
||||||
|
parseNamedRecord csv
|
||||||
|
= CourseApplicationsTableCsv
|
||||||
|
<$> csv .:?? "allocation"
|
||||||
|
<*> csv .:?? "application"
|
||||||
|
<*> csv .:?? "name"
|
||||||
|
<*> csv .:?? "matriculation"
|
||||||
|
<*> csv .:?? "field"
|
||||||
|
<*> csv .:?? "degree"
|
||||||
|
<*> csv .:?? "semester"
|
||||||
|
<*> csv .:?? "text"
|
||||||
|
<*> csv .:?? "has-files"
|
||||||
|
<*> csv .:?? "veto"
|
||||||
|
<*> csv .:?? "rating"
|
||||||
|
<*> csv .:?? "comment"
|
||||||
|
|
||||||
|
instance Csv.DefaultOrdered CourseApplicationsTableCsv where
|
||||||
|
headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions
|
||||||
|
|
||||||
|
instance CsvColumnsExplained CourseApplicationsTableCsv where
|
||||||
|
csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList
|
||||||
|
[ ('csvCAAllocation , MsgCsvColumnApplicationsAllocation )
|
||||||
|
, ('csvCAApplication , MsgCsvColumnApplicationsApplication )
|
||||||
|
, ('csvCAName , MsgCsvColumnApplicationsName )
|
||||||
|
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
|
||||||
|
, ('csvCAField , MsgCsvColumnApplicationsField )
|
||||||
|
, ('csvCADegree , MsgCsvColumnApplicationsDegree )
|
||||||
|
, ('csvCASemester , MsgCsvColumnApplicationsSemester )
|
||||||
|
, ('csvCAText , MsgCsvColumnApplicationsText )
|
||||||
|
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
|
||||||
|
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
|
||||||
|
, ('csvCARating , MsgCsvColumnApplicationsRating )
|
||||||
|
, ('csvCAComment , MsgCsvColumnApplicationsComment )
|
||||||
|
]
|
||||||
|
|
||||||
|
data CourseApplicationsTableCsvActionClass
|
||||||
|
= CourseApplicationsTableCsvSetField
|
||||||
|
| CourseApplicationsTableCsvSetVeto
|
||||||
|
| CourseApplicationsTableCsvSetRating
|
||||||
|
| CourseApplicationsTableCsvSetComment
|
||||||
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||||
|
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
|
||||||
|
|
||||||
|
data CourseApplicationsTableCsvAction
|
||||||
|
= CourseApplicationsTableCsvSetFieldData
|
||||||
|
{ caCsvActApplication :: CourseApplicationId
|
||||||
|
, caCsvActField :: Maybe StudyFeaturesId
|
||||||
|
}
|
||||||
|
| CourseApplicationsTableCsvSetVetoData
|
||||||
|
{ caCsvActApplication :: CourseApplicationId
|
||||||
|
, caCsvActVeto :: Bool
|
||||||
|
}
|
||||||
|
| CourseApplicationsTableCsvSetRatingData
|
||||||
|
{ caCsvActApplication :: CourseApplicationId
|
||||||
|
, caCsvActRating :: Maybe ExamGrade
|
||||||
|
}
|
||||||
|
| CourseApplicationsTableCsvSetCommentData
|
||||||
|
{ caCsvActApplication :: CourseApplicationId
|
||||||
|
, caCsvActComment :: Maybe Text
|
||||||
|
}
|
||||||
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
|
deriveJSON defaultOptions
|
||||||
|
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
|
||||||
|
, fieldLabelModifier = camelToPathPiece' 3
|
||||||
|
, sumEncoding = TaggedObject "action" "data"
|
||||||
|
} ''CourseApplicationsTableCsvAction
|
||||||
|
|
||||||
|
data CourseApplicationsTableCsvException
|
||||||
|
= CourseApplicationsTableCsvExceptionNoMatchingUser
|
||||||
|
| CourseApplicationsTableCsvExceptionNoMatchingAllocation
|
||||||
|
| CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
|
||||||
|
deriving (Show, Generic, Typeable)
|
||||||
|
|
||||||
|
instance Exception CourseApplicationsTableCsvException
|
||||||
|
|
||||||
|
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
|
||||||
|
|
||||||
|
|
||||||
|
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||||
|
getCApplicationsR = postCApplicationsR
|
||||||
|
postCApplicationsR tid ssh csh = do
|
||||||
|
table <- runDB $ do
|
||||||
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
|
||||||
|
let
|
||||||
|
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||||
|
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||||
|
|
||||||
|
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
||||||
|
participantLink uid = do
|
||||||
|
cID <- encrypt uid
|
||||||
|
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
||||||
|
|
||||||
|
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||||
|
dbtSQLQuery = runReaderT $ do
|
||||||
|
courseApplication <- view queryCourseApplication
|
||||||
|
hasFiles <- view queryHasFiles
|
||||||
|
user <- view queryUser
|
||||||
|
allocation <- view queryAllocation
|
||||||
|
studyFeatures <- view queryStudyFeatures
|
||||||
|
studyTerms <- view queryStudyTerms
|
||||||
|
studyDegree <- view queryStudyDegree
|
||||||
|
|
||||||
|
lift $ do
|
||||||
|
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||||
|
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||||
|
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||||
|
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||||
|
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||||
|
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||||
|
|
||||||
|
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||||
|
|
||||||
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||||
|
dbtProj = runReaderT $ do
|
||||||
|
appId <- view $ resultCourseApplication . _entityKey
|
||||||
|
cID <- encrypt appId
|
||||||
|
|
||||||
|
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||||
|
|
||||||
|
view id
|
||||||
|
|
||||||
|
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||||
|
|
||||||
|
dbtColonnade :: Colonnade Sortable _ _
|
||||||
|
dbtColonnade = mconcat
|
||||||
|
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||||
|
, colApplicationId (resultCourseApplication . _entityKey)
|
||||||
|
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||||
|
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||||
|
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||||
|
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||||
|
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||||
|
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||||
|
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||||
|
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||||
|
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||||
|
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtSorting = mconcat
|
||||||
|
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||||
|
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||||
|
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||||
|
, sortStudyTerms queryStudyTerms
|
||||||
|
, sortStudyDegree queryStudyDegree
|
||||||
|
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||||
|
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||||
|
, sortApplicationFiles queryHasFiles
|
||||||
|
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||||
|
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||||
|
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtFilter = mconcat
|
||||||
|
[ fltrAllocation queryAllocation
|
||||||
|
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||||
|
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||||
|
, fltrStudyTerms queryStudyTerms
|
||||||
|
, fltrStudyDegree queryStudyDegree
|
||||||
|
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||||
|
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||||
|
, fltrApplicationFiles queryHasFiles
|
||||||
|
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||||
|
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||||
|
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||||
|
]
|
||||||
|
dbtFilterUI = mconcat
|
||||||
|
[ fltrAllocationUI
|
||||||
|
, fltrUserNameUI'
|
||||||
|
, fltrUserMatriculationUI
|
||||||
|
, fltrStudyTermsUI
|
||||||
|
, fltrStudyDegreeUI
|
||||||
|
, fltrStudyFeaturesSemesterUI
|
||||||
|
, fltrApplicationTextUI
|
||||||
|
, fltrApplicationFilesUI
|
||||||
|
, fltrApplicationVetoUI
|
||||||
|
, fltrApplicationRatingPointsUI
|
||||||
|
, fltrApplicationRatingCommentUI
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtStyle = def
|
||||||
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||||
|
}
|
||||||
|
dbtParams = def
|
||||||
|
|
||||||
|
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
|
||||||
|
dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
|
||||||
|
<$> preview (resultAllocation . _entityVal . _allocationShorthand)
|
||||||
|
<*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
|
||||||
|
<*> preview (resultUser . _entityVal . _userDisplayName)
|
||||||
|
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
|
||||||
|
<*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
|
||||||
|
<*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
|
||||||
|
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||||
|
<*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
|
||||||
|
<*> preview resultHasFiles
|
||||||
|
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
|
||||||
|
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just)
|
||||||
|
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just)
|
||||||
|
dbtCsvDecode = Just DBTCsvDecode
|
||||||
|
{ dbtCsvRowKey = \csv -> do
|
||||||
|
appRes <- lift $ guessUser csv
|
||||||
|
case appRes of
|
||||||
|
Right appId -> return $ E.Value appId
|
||||||
|
Left uid -> do
|
||||||
|
alloc <- lift $ guessAllocation csv
|
||||||
|
[appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2]
|
||||||
|
return $ E.Value appId
|
||||||
|
, dbtCsvComputeActions = \case
|
||||||
|
DBCsvDiffMissing{}
|
||||||
|
-> return () -- no deletion
|
||||||
|
DBCsvDiffNew{}
|
||||||
|
-> return () -- no addition
|
||||||
|
DBCsvDiffExisting{..} -> do
|
||||||
|
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
|
||||||
|
|
||||||
|
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||||
|
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
|
||||||
|
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
|
||||||
|
|
||||||
|
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
|
||||||
|
whenIsJust mVeto $ \veto ->
|
||||||
|
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
|
||||||
|
yield $ CourseApplicationsTableCsvSetVetoData appId veto
|
||||||
|
|
||||||
|
when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $
|
||||||
|
yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating)
|
||||||
|
|
||||||
|
when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
|
||||||
|
yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
|
||||||
|
, dbtCsvClassifyAction = \case
|
||||||
|
CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField
|
||||||
|
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
|
||||||
|
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
|
||||||
|
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
|
||||||
|
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
|
||||||
|
, dbtCsvExecuteActions = do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
C.mapM_ $ \case
|
||||||
|
CourseApplicationsTableCsvSetFieldData{..} -> do
|
||||||
|
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
|
||||||
|
, CourseApplicationTime =. now
|
||||||
|
]
|
||||||
|
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||||
|
CourseApplicationsTableCsvSetVetoData{..} -> do
|
||||||
|
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
|
||||||
|
, CourseApplicationRatingTime =. Just now
|
||||||
|
]
|
||||||
|
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||||
|
CourseApplicationsTableCsvSetRatingData{..} -> do
|
||||||
|
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating
|
||||||
|
, CourseApplicationRatingTime =. Just now
|
||||||
|
]
|
||||||
|
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||||
|
CourseApplicationsTableCsvSetCommentData{..} -> do
|
||||||
|
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment
|
||||||
|
, CourseApplicationRatingTime =. Just now
|
||||||
|
]
|
||||||
|
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||||
|
return $ CourseR tid ssh csh CApplicationsR
|
||||||
|
, dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
|
||||||
|
CourseApplicationsTableCsvSetFieldData{..} ->
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
^{existingApplicantName' caCsvActApplication}
|
||||||
|
$maybe features <- caCsvActField
|
||||||
|
, ^{studyFeaturesWidget features}
|
||||||
|
$nothing
|
||||||
|
, _{MsgCourseStudyFeatureNone}
|
||||||
|
|]
|
||||||
|
CourseApplicationsTableCsvSetVetoData{..} ->
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
^{existingApplicantName' caCsvActApplication}
|
||||||
|
$if caCsvActVeto
|
||||||
|
, _{MsgCourseApplicationVeto}
|
||||||
|
$else
|
||||||
|
, _{MsgCourseApplicationNoVeto}
|
||||||
|
|]
|
||||||
|
CourseApplicationsTableCsvSetRatingData{..} ->
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
^{existingApplicantName' caCsvActApplication}
|
||||||
|
$maybe newResult <- caCsvActRating
|
||||||
|
, _{newResult}
|
||||||
|
$nothing
|
||||||
|
, _{MsgCourseApplicationNoRatingPoints}
|
||||||
|
|]
|
||||||
|
CourseApplicationsTableCsvSetCommentData{..} ->
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
^{existingApplicantName' caCsvActApplication}
|
||||||
|
$if is _Nothing caCsvActComment
|
||||||
|
, _{MsgCourseApplicationNoRatingComment}
|
||||||
|
|]
|
||||||
|
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||||
|
, dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text
|
||||||
|
}
|
||||||
|
where
|
||||||
|
guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId)
|
||||||
|
guessUser csv = do
|
||||||
|
mApp <- runMaybeT $ do
|
||||||
|
appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just
|
||||||
|
CourseApplication{..} <- MaybeT $ get appId
|
||||||
|
guard $ courseApplicationCourse == cid
|
||||||
|
return appId
|
||||||
|
|
||||||
|
maybe (Left <$> guessUser' csv) (return . Right) mApp
|
||||||
|
where
|
||||||
|
guessUser' :: CourseApplicationsTableCsv -> DB UserId
|
||||||
|
guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do
|
||||||
|
users <- E.select . E.from $ \user -> do
|
||||||
|
E.where_ . E.and $ catMaybes
|
||||||
|
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation
|
||||||
|
, (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName
|
||||||
|
]
|
||||||
|
return $ user E.^. UserId
|
||||||
|
case users of
|
||||||
|
[E.Value uid]
|
||||||
|
-> return uid
|
||||||
|
_other
|
||||||
|
-> throwM CourseApplicationsTableCsvExceptionNoMatchingUser
|
||||||
|
|
||||||
|
guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId)
|
||||||
|
guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do
|
||||||
|
mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid
|
||||||
|
case mAlloc of
|
||||||
|
Just (Entity allocId Allocation{..})
|
||||||
|
| allocationShorthand == ash
|
||||||
|
-> return allocId
|
||||||
|
_other
|
||||||
|
-> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation
|
||||||
|
|
||||||
|
existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget
|
||||||
|
existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname
|
||||||
|
where
|
||||||
|
Entity _ User{..} = existing ^. singular (ix appId . resultUser)
|
||||||
|
|
||||||
|
lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
|
||||||
|
lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
|
||||||
|
appRes <- guessUser csv
|
||||||
|
(uid, oldFeatures) <- case appRes of
|
||||||
|
Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
|
||||||
|
Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
|
||||||
|
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||||
|
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||||
|
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
|
||||||
|
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
|
||||||
|
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||||
|
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||||
|
E.where_ . E.and $ catMaybes
|
||||||
|
[ do
|
||||||
|
field <- csvCAField
|
||||||
|
return . E.or $ catMaybes
|
||||||
|
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||||
|
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||||
|
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||||
|
]
|
||||||
|
, do
|
||||||
|
degree <- csvCADegree
|
||||||
|
return . E.or $ catMaybes
|
||||||
|
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||||
|
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||||
|
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||||
|
]
|
||||||
|
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
|
||||||
|
]
|
||||||
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||||
|
let isActiveOrPrevious = E.or
|
||||||
|
$ (studyFeatures E.^. StudyFeaturesValid)
|
||||||
|
: [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
|
||||||
|
| Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
|
||||||
|
]
|
||||||
|
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||||
|
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||||
|
return $ studyFeatures E.^. StudyFeaturesId
|
||||||
|
case studyFeatures of
|
||||||
|
[E.Value fid] -> return $ Just fid
|
||||||
|
_other
|
||||||
|
| is _Nothing csvCAField
|
||||||
|
, is _Nothing csvCADegree
|
||||||
|
, is _Nothing csvCASemester
|
||||||
|
-> return Nothing
|
||||||
|
_other
|
||||||
|
| [Entity _ CourseApplication{..}] <- oldFeatures
|
||||||
|
, Just sfid <- courseApplicationField
|
||||||
|
, E.Value sfid `elem` studyFeatures
|
||||||
|
-> return $ Just sfid
|
||||||
|
_other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
|
||||||
|
|
||||||
|
|
||||||
|
dbtIdent = courseApplicationsIdent
|
||||||
|
|
||||||
|
psValidator :: PSValidator _ _
|
||||||
|
psValidator = def
|
||||||
|
|
||||||
|
dbTableWidget' psValidator DBTable{..}
|
||||||
|
|
||||||
|
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||||
|
|
||||||
|
siteLayoutMsg title $ do
|
||||||
|
setTitleI title
|
||||||
|
table
|
||||||
@ -5,7 +5,6 @@ module Handler.Course.Edit
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Invitations
|
import Handler.Utils.Invitations
|
||||||
@ -542,7 +541,15 @@ upsertAllocationCourse cid cfAllocation = do
|
|||||||
-> return True
|
-> return True
|
||||||
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
||||||
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
||||||
-> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired
|
-> let anyChanges
|
||||||
|
| Just AllocationCourseForm{..} <- cfAllocation
|
||||||
|
, Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
|
||||||
|
= or [ acfAllocation /= allocationCourseAllocation
|
||||||
|
, acfMinCapacity /= allocationCourseMinCapacity
|
||||||
|
]
|
||||||
|
| otherwise
|
||||||
|
= True
|
||||||
|
in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
|
||||||
| otherwise
|
| otherwise
|
||||||
-> return True
|
-> return True
|
||||||
|
|
||||||
|
|||||||
@ -8,7 +8,6 @@ module Handler.Course.LecturerInvite
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils.Invitations
|
import Handler.Utils.Invitations
|
||||||
|
|
||||||
|
|||||||
@ -10,7 +10,6 @@ import Import
|
|||||||
|
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
-- import Utils.DB
|
-- import Utils.DB
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
@ -26,39 +25,39 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
|
|
||||||
|
|
||||||
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
||||||
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User])
|
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation))
|
||||||
|
|
||||||
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
|
||||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
||||||
[whamlet|_{courseName}|]
|
[whamlet|_{courseName}|]
|
||||||
|
|
||||||
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colDescription = sortable Nothing mempty
|
colDescription = sortable Nothing mempty
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
|
||||||
case courseDescription of
|
case courseDescription of
|
||||||
Nothing -> mempty
|
Nothing -> mempty
|
||||||
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
|
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
|
||||||
|
|
||||||
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
|
||||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
|
||||||
|
|
||||||
colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
|
||||||
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
|
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
|
||||||
|
|
||||||
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _) } ->
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _) } ->
|
||||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
|
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
|
||||||
|
|
||||||
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||||
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
|
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
|
||||||
$ \DBRow{ dbrOutput=(_, _, registered, _, _) } -> tickmarkCell registered
|
$ \DBRow{ dbrOutput=(_, _, registered, _, _, _) } -> tickmarkCell registered
|
||||||
|
|
||||||
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
||||||
|
|
||||||
@ -91,7 +90,9 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
|
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
|
||||||
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
|
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
|
||||||
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
||||||
return (course, participants, registered, school, lecturerList)
|
courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)
|
||||||
|
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
|
||||||
|
return (course, participants, registered, school, lecturerList, courseAlloc)
|
||||||
snd <$> dbTable psValidator DBTable
|
snd <$> dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||||
@ -142,7 +143,22 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
Nothing -> E.val True
|
Nothing -> E.val True
|
||||||
Just b -> let regTo = course E.^. CourseRegisterTo
|
Just b -> let regTo = course E.^. CourseRegisterTo
|
||||||
regFrom = course E.^. CourseRegisterFrom
|
regFrom = course E.^. CourseRegisterFrom
|
||||||
in (E.==.) (E.val b) $ (E.isNothing regTo E.||. E.val (Just now) E.<=. regTo) E.&&. E.val (Just now) E.>=. regFrom
|
courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
|
||||||
|
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) regTo
|
||||||
|
alloc allocation = do
|
||||||
|
E.where_ . E.exists . E.from $ \allocationCourse ->
|
||||||
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||||
|
return allocation
|
||||||
|
allocOpen allocation = ( E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom)
|
||||||
|
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo)
|
||||||
|
)
|
||||||
|
E.||. ( courseOpen
|
||||||
|
E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse)
|
||||||
|
)
|
||||||
|
in (E.==. E.val b) $ ( courseOpen
|
||||||
|
E.&&. E.not_ (E.exists . void $ E.from alloc)
|
||||||
|
)
|
||||||
|
E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc)
|
||||||
)
|
)
|
||||||
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
|
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
|
||||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||||
@ -165,8 +181,8 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
]
|
]
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||||
, dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4)
|
, dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4) (_dbrOutput . _6 . _Just)
|
||||||
-- ^ course ^ lecturer list ^ isRegistered ^ school
|
-- ^ course ^ lecturer list ^ isRegistered ^ school ^ allocation
|
||||||
}
|
}
|
||||||
, dbtParams = def
|
, dbtParams = def
|
||||||
, dbtIdent = "courses" :: Text
|
, dbtIdent = "courses" :: Text
|
||||||
|
|||||||
@ -8,7 +8,6 @@ module Handler.Course.ParticipantInvite
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Invitations
|
import Handler.Utils.Invitations
|
||||||
|
|||||||
@ -7,7 +7,6 @@ module Handler.Course.Register
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
|
|||||||
@ -12,7 +12,6 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Handler.Course.User
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|||||||
@ -9,7 +9,6 @@ module Handler.Course.Users
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Database
|
import Handler.Utils.Database
|
||||||
|
|||||||
@ -5,8 +5,6 @@ module Handler.CryptoIDDispatch
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Data.Proxy
|
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||||
|
|||||||
@ -9,8 +9,6 @@ import Handler.Utils
|
|||||||
import Handler.Utils.Exam
|
import Handler.Utils.Exam
|
||||||
import Handler.Utils.Invitations
|
import Handler.Utils.Invitations
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import Data.Semigroup (Option(..))
|
import Data.Semigroup (Option(..))
|
||||||
|
|||||||
@ -12,8 +12,6 @@ import Import
|
|||||||
import Handler.Utils.Invitations
|
import Handler.Utils.Invitations
|
||||||
import Handler.Utils.Exam
|
import Handler.Utils.Exam
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Text.Hamlet (ihamlet)
|
import Text.Hamlet (ihamlet)
|
||||||
|
|
||||||
import Data.Aeson hiding (Result(..))
|
import Data.Aeson hiding (Result(..))
|
||||||
|
|||||||
@ -6,8 +6,6 @@ import Import
|
|||||||
import Handler.Exam.Form
|
import Handler.Exam.Form
|
||||||
import Handler.Exam.CorrectorInvite
|
import Handler.Exam.CorrectorInvite
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|||||||
@ -8,8 +8,6 @@ module Handler.Exam.Form
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Lens hiding (parts)
|
|
||||||
|
|
||||||
import Handler.Exam.CorrectorInvite
|
import Handler.Exam.CorrectorInvite
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
@ -230,12 +228,12 @@ examPartsForm prev = wFormToAForm $ do
|
|||||||
|
|
||||||
examFormTemplate :: Entity Exam -> DB ExamForm
|
examFormTemplate :: Entity Exam -> DB ExamForm
|
||||||
examFormTemplate (Entity eId Exam{..}) = do
|
examFormTemplate (Entity eId Exam{..}) = do
|
||||||
parts <- selectList [ ExamPartExam ==. eId ] []
|
examParts <- selectList [ ExamPartExam ==. eId ] []
|
||||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
||||||
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
|
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
|
||||||
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
|
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
|
||||||
|
|
||||||
parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
||||||
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
|
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
|
||||||
|
|
||||||
return ExamForm
|
return ExamForm
|
||||||
@ -267,7 +265,7 @@ examFormTemplate (Entity eId Exam{..}) = do
|
|||||||
, eofDescription = examOccurrenceDescription
|
, eofDescription = examOccurrenceDescription
|
||||||
}
|
}
|
||||||
, efExamParts = Set.fromList $ do
|
, efExamParts = Set.fromList $ do
|
||||||
(Just -> epfId, ExamPart{..}) <- parts'
|
(Just -> epfId, ExamPart{..}) <- examParts'
|
||||||
return ExamPartForm
|
return ExamPartForm
|
||||||
{ epfId
|
{ epfId
|
||||||
, epfName = examPartName
|
, epfName = examPartName
|
||||||
|
|||||||
@ -17,8 +17,6 @@ import qualified Data.Set as Set
|
|||||||
|
|
||||||
import Text.Hamlet (ihamlet)
|
import Text.Hamlet (ihamlet)
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Aeson hiding (Result(..))
|
import Data.Aeson hiding (Result(..))
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -5,8 +5,6 @@ module Handler.Exam.Show
|
|||||||
import Import
|
import Import
|
||||||
import Handler.Exam.Register
|
import Handler.Exam.Register
|
||||||
|
|
||||||
import Utils.Lens hiding (parts)
|
|
||||||
|
|
||||||
import Data.Map ((!?))
|
import Data.Map ((!?))
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
@ -24,7 +22,7 @@ getEShowR tid ssh csh examn = do
|
|||||||
cTime <- liftIO getCurrentTime
|
cTime <- liftIO getCurrentTime
|
||||||
mUid <- maybeAuthId
|
mUid <- maybeAuthId
|
||||||
|
|
||||||
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
|
(Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
|
||||||
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
||||||
|
|
||||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||||
@ -35,12 +33,12 @@ getEShowR tid ssh csh examn = do
|
|||||||
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
||||||
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||||
|
|
||||||
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
||||||
|
|
||||||
resultsRaw <- for mUid $ \uid ->
|
resultsRaw <- for mUid $ \uid ->
|
||||||
E.select . E.from $ \examPartResult -> do
|
E.select . E.from $ \examPartResult -> do
|
||||||
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
|
||||||
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
|
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey examParts)
|
||||||
return examPartResult
|
return examPartResult
|
||||||
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
|
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
|
||||||
|
|
||||||
@ -66,7 +64,7 @@ getEShowR tid ssh csh examn = do
|
|||||||
|
|
||||||
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||||
|
|
||||||
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
|
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
|
||||||
|
|
||||||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||||||
registerWidget
|
registerWidget
|
||||||
|
|||||||
@ -6,7 +6,6 @@ module Handler.Exam.Users
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Exam
|
import Handler.Utils.Exam
|
||||||
import Handler.Utils.Table.Columns
|
import Handler.Utils.Table.Columns
|
||||||
@ -31,7 +30,6 @@ import qualified Data.Conduit.List as C
|
|||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import Numeric.Lens (integral)
|
import Numeric.Lens (integral)
|
||||||
import Control.Arrow (Kleisli(..))
|
|
||||||
|
|
||||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||||
|
|
||||||
@ -109,7 +107,7 @@ data ExamUserTableCsv = ExamUserTableCsv
|
|||||||
, csvEUserExerciseNumPasses :: Maybe Int
|
, csvEUserExerciseNumPasses :: Maybe Int
|
||||||
, csvEUserExercisePointsMax :: Maybe Points
|
, csvEUserExercisePointsMax :: Maybe Points
|
||||||
, csvEUserExerciseNumPassesMax :: Maybe Int
|
, csvEUserExerciseNumPassesMax :: Maybe Int
|
||||||
, csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
, csvEUserExamResult :: Maybe ExamResultPassedGrade
|
||||||
, csvEUserCourseNote :: Maybe Html
|
, csvEUserCourseNote :: Maybe Html
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
@ -124,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where
|
|||||||
instance FromNamedRecord ExamUserTableCsv where
|
instance FromNamedRecord ExamUserTableCsv where
|
||||||
parseNamedRecord csv -- Manually defined awaiting issue #427
|
parseNamedRecord csv -- Manually defined awaiting issue #427
|
||||||
= ExamUserTableCsv
|
= ExamUserTableCsv
|
||||||
<$> csv .:? "surname"
|
<$> csv .:?? "surname"
|
||||||
<*> csv .:? "first-name"
|
<*> csv .:?? "first-name"
|
||||||
<*> csv .:? "name"
|
<*> csv .:?? "name"
|
||||||
<*> csv .:? "matriculation"
|
<*> csv .:?? "matriculation"
|
||||||
<*> csv .:? "field"
|
<*> csv .:?? "field"
|
||||||
<*> csv .:? "degree"
|
<*> csv .:?? "degree"
|
||||||
<*> csv .:? "semester"
|
<*> csv .:?? "semester"
|
||||||
<*> csv .:? "occurrence"
|
<*> csv .:?? "occurrence"
|
||||||
<*> csv .:? "exercise-points"
|
<*> csv .:?? "exercise-points"
|
||||||
<*> csv .:? "exercise-num-passes"
|
<*> csv .:?? "exercise-num-passes"
|
||||||
<*> csv .:? "exercise-points-max"
|
<*> csv .:?? "exercise-points-max"
|
||||||
<*> csv .:? "exercise-num-passes-max"
|
<*> csv .:?? "exercise-num-passes-max"
|
||||||
<*> csv .:? "exam-result"
|
<*> csv .:?? "exam-result"
|
||||||
<*> csv .:? "course-note"
|
<*> csv .:?? "course-note"
|
||||||
where
|
|
||||||
(.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
|
|
||||||
m .:? name = Csv.lookup m name <|> return Nothing
|
|
||||||
|
|
||||||
instance DefaultOrdered ExamUserTableCsv where
|
instance DefaultOrdered ExamUserTableCsv where
|
||||||
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
||||||
@ -209,7 +204,7 @@ data ExamUserCsvAction
|
|||||||
}
|
}
|
||||||
| ExamUserCsvSetResultData
|
| ExamUserCsvSetResultData
|
||||||
{ examUserCsvActUser :: UserId
|
{ examUserCsvActUser :: UserId
|
||||||
, examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
, examUserCsvActExamResult :: Maybe ExamResultPassedGrade
|
||||||
}
|
}
|
||||||
| ExamUserCsvSetCourseNoteData
|
| ExamUserCsvSetCourseNoteData
|
||||||
{ examUserCsvActUser :: UserId
|
{ examUserCsvActUser :: UserId
|
||||||
@ -244,8 +239,8 @@ postEUsersR tid ssh csh examn = do
|
|||||||
showPasses = numSheetsPasses allBoni /= 0
|
showPasses = numSheetsPasses allBoni /= 0
|
||||||
showPoints = getSum (numSheetsPoints allBoni) /= 0
|
showPoints = getSum (numSheetsPoints allBoni) /= 0
|
||||||
|
|
||||||
resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade
|
resultView :: ExamResultGrade -> ExamResultPassedGrade
|
||||||
resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades
|
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
|
||||||
|
|
||||||
let
|
let
|
||||||
examUsersDBTable = DBTable{..}
|
examUsersDBTable = DBTable{..}
|
||||||
@ -471,7 +466,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
deleteBy $ UniqueExamResult eid examUserCsvActUser
|
deleteBy $ UniqueExamResult eid examUserCsvActUser
|
||||||
audit $ TransactionExamResultDeleted eid examUserCsvActUser
|
audit $ TransactionExamResultDeleted eid examUserCsvActUser
|
||||||
Just res -> do
|
Just res -> do
|
||||||
let res' = either (over _examResult $ review passingGrade) id res
|
let res' = either (review passingGrade) id <$> res
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
void $ upsertBy
|
void $ upsertBy
|
||||||
(UniqueExamResult eid examUserCsvActUser)
|
(UniqueExamResult eid examUserCsvActUser)
|
||||||
@ -550,11 +545,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
$newline never
|
$newline never
|
||||||
^{nameWidget userDisplayName userSurname}
|
^{nameWidget userDisplayName userSurname}
|
||||||
$maybe newResult <- examUserCsvActExamResult
|
$maybe newResult <- examUserCsvActExamResult
|
||||||
$case newResult
|
, _{newResult}
|
||||||
$of Left pResult
|
|
||||||
, _{pResult}
|
|
||||||
$of Right gResult
|
|
||||||
, _{gResult}
|
|
||||||
$nothing
|
$nothing
|
||||||
, _{MsgExamResultNone}
|
, _{MsgExamResultNone}
|
||||||
|]
|
|]
|
||||||
@ -572,14 +563,6 @@ postEUsersR tid ssh csh examn = do
|
|||||||
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
|
||||||
studyFeaturesWidget featId = do
|
|
||||||
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
|
||||||
[whamlet|
|
|
||||||
$newline never
|
|
||||||
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
|
||||||
|]
|
|
||||||
|
|
||||||
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
||||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||||
where
|
where
|
||||||
@ -617,30 +600,39 @@ postEUsersR tid ssh csh examn = do
|
|||||||
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
||||||
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
||||||
uid <- view _2 <$> guessUser csv
|
uid <- view _2 <$> guessUser csv
|
||||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
|
oldFeatures <- getBy $ UniqueParticipant uid examCourse
|
||||||
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||||
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||||
E.where_ . E.and $ catMaybes
|
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
|
||||||
[ do
|
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
|
||||||
field <- csvEUserField
|
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||||
return . E.or $ catMaybes
|
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||||
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
E.where_ . E.and $ catMaybes
|
||||||
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
[ do
|
||||||
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
field <- csvEUserField
|
||||||
]
|
return . E.or $ catMaybes
|
||||||
, do
|
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||||
degree <- csvEUserDegree
|
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||||
return . E.or $ catMaybes
|
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||||
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
]
|
||||||
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
, do
|
||||||
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
degree <- csvEUserDegree
|
||||||
]
|
return . E.or $ catMaybes
|
||||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
|
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||||
]
|
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||||
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
]
|
||||||
E.limit 2
|
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
|
||||||
return $ studyFeatures E.^. StudyFeaturesId
|
]
|
||||||
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||||
|
let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
||||||
|
isActiveOrPrevious = case oldFeatures of
|
||||||
|
Just (Entity _ CourseParticipant{courseParticipantField = Just sfid})
|
||||||
|
-> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId)
|
||||||
|
_ -> isActive
|
||||||
|
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||||
|
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||||
|
return $ studyFeatures E.^. StudyFeaturesId
|
||||||
case studyFeatures of
|
case studyFeatures of
|
||||||
[E.Value fid] -> return $ Just fid
|
[E.Value fid] -> return $ Just fid
|
||||||
_other
|
_other
|
||||||
@ -648,6 +640,11 @@ postEUsersR tid ssh csh examn = do
|
|||||||
, is _Nothing csvEUserDegree
|
, is _Nothing csvEUserDegree
|
||||||
, is _Nothing csvEUserSemester
|
, is _Nothing csvEUserSemester
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
|
_other
|
||||||
|
| Just (Entity _ CourseParticipant{..}) <- oldFeatures
|
||||||
|
, Just sfid <- courseParticipantField
|
||||||
|
, E.Value sfid `elem` studyFeatures
|
||||||
|
-> return $ Just sfid
|
||||||
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||||
|
|
||||||
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
||||||
|
|||||||
@ -5,8 +5,6 @@ import Import
|
|||||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||||
import qualified Data.Text.Lazy.Builder as Builder
|
import qualified Data.Text.Lazy.Builder as Builder
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.UUID as UUID
|
import qualified Data.UUID as UUID
|
||||||
|
|
||||||
import Data.Semigroup (Min(..), Max(..))
|
import Data.Semigroup (Min(..), Max(..))
|
||||||
|
|||||||
@ -2,7 +2,6 @@ module Handler.Home where
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
|
||||||
@ -15,142 +14,16 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
getHomeR :: Handler Html
|
getHomeR :: Handler Html
|
||||||
getHomeR = do
|
getHomeR = do
|
||||||
muid <- maybeAuthId
|
muid <- maybeAuthId
|
||||||
upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams
|
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI MsgHomeHeading
|
setTitleI MsgHomeHeading
|
||||||
fromMaybe mempty upcomingExamsWidget
|
case muid of
|
||||||
maybe mempty homeUpcomingSheets muid
|
Just uid -> do
|
||||||
homeOpenAllocations
|
homeUpcomingExams uid
|
||||||
homeOpenCourses
|
homeUpcomingSheets uid
|
||||||
|
Nothing ->
|
||||||
|
$(i18nWidgetFile "unauth-home")
|
||||||
|
|
||||||
|
|
||||||
homeOpenAllocations :: Widget
|
|
||||||
homeOpenAllocations = do
|
|
||||||
cTime <- liftIO getCurrentTime
|
|
||||||
let tableData :: E.SqlExpr (Entity Allocation)
|
|
||||||
-> E.SqlQuery (E.SqlExpr (Entity Allocation))
|
|
||||||
tableData allocation = do
|
|
||||||
E.where_ $ E.maybe E.false (\rf -> rf E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom)
|
|
||||||
E.&&. E.maybe E.true (\rt -> rt E.>=. E.val cTime) (allocation E.^. AllocationRegisterTo)
|
|
||||||
return allocation
|
|
||||||
|
|
||||||
colonnade :: Colonnade Sortable (DBRow (Entity Allocation)) (DBCell (HandlerT UniWorX IO) ())
|
|
||||||
colonnade = mconcat
|
|
||||||
[ -- dbRow
|
|
||||||
sortable (Just "term") (i18nCell MsgTerm)
|
|
||||||
$ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } ->
|
|
||||||
anchorCell (TermCourseListR allocationTerm) [whamlet|#{allocationTerm}|]
|
|
||||||
, sortable (Just "schoolshort") (i18nCell MsgAllocationSchoolShort)
|
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Allocation{..}) } ->
|
|
||||||
anchorCell (TermSchoolCourseListR allocationTerm allocationSchool) [whamlet|_{unSchoolKey allocationSchool}|]
|
|
||||||
, sortable (Just "allocation") (i18nCell MsgAllocation) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> do
|
|
||||||
anchorCell (AllocationR allocationTerm allocationSchool allocationShorthand AShowR) allocationName
|
|
||||||
, sortable (Just "deadline") (i18nCell MsgAllocationRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } ->
|
|
||||||
cell $ traverse (formatTime SelFormatDateTime) allocationRegisterTo >>= maybe mempty toWidget
|
|
||||||
]
|
|
||||||
validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "allocation"]
|
|
||||||
allocationTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
|
|
||||||
{ dbtSQLQuery = tableData
|
|
||||||
, dbtRowKey = (E.^. AllocationId)
|
|
||||||
, dbtColonnade = colonnade
|
|
||||||
, dbtProj = return
|
|
||||||
, dbtSorting = Map.fromList
|
|
||||||
[ ( "term"
|
|
||||||
, SortColumn $ \allocation -> allocation E.^. AllocationTerm
|
|
||||||
)
|
|
||||||
, ( "schoolshort"
|
|
||||||
, SortColumn $ \allocation -> allocation E.^. AllocationSchool
|
|
||||||
)
|
|
||||||
, ( "allocation"
|
|
||||||
, SortColumn $ \allocation -> allocation E.^. AllocationShorthand
|
|
||||||
)
|
|
||||||
, ( "deadline"
|
|
||||||
, SortColumn $ \allocation -> allocation E.^. AllocationRegisterTo
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, dbtFilter = mempty
|
|
||||||
, dbtFilterUI = mempty
|
|
||||||
, dbtStyle = def
|
|
||||||
, dbtParams = def
|
|
||||||
, dbtIdent = "open-allocations" :: Text
|
|
||||||
, dbtCsvEncode = noCsvEncode
|
|
||||||
, dbtCsvDecode = Nothing
|
|
||||||
}
|
|
||||||
$(widgetFile "home/openAllocations")
|
|
||||||
|
|
||||||
|
|
||||||
homeOpenCourses :: Widget
|
|
||||||
homeOpenCourses = do
|
|
||||||
cTime <- liftIO getCurrentTime
|
|
||||||
let tableData :: E.SqlExpr (Entity Course)
|
|
||||||
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
|
||||||
tableData course = do
|
|
||||||
E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
|
|
||||||
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
|
|
||||||
E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
|
|
||||||
E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
|
|
||||||
)
|
|
||||||
E.&&. E.not_ (E.exists . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
|
|
||||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
||||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
||||||
E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterFrom)
|
|
||||||
E.||. E.maybe E.false (\rt -> rt E.<. E.val cTime) (allocation E.^. AllocationRegisterTo)
|
|
||||||
E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterByCourse)
|
|
||||||
)
|
|
||||||
return course
|
|
||||||
|
|
||||||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
|
|
||||||
colonnade = mconcat
|
|
||||||
[ -- dbRow
|
|
||||||
sortable (Just "term") (i18nCell MsgTerm)
|
|
||||||
$ \DBRow{ dbrOutput=Entity{entityVal = Course{..}} } ->
|
|
||||||
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
|
|
||||||
, sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
|
||||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}) } ->
|
|
||||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{unSchoolKey courseSchool}|]
|
|
||||||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
|
|
||||||
let tid = courseTerm course
|
|
||||||
ssh = courseSchool course
|
|
||||||
csh = courseShorthand course
|
|
||||||
anchorCell (CourseR tid ssh csh CShowR) csh
|
|
||||||
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
|
||||||
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
|
|
||||||
]
|
|
||||||
validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "course"]
|
|
||||||
courseTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
|
|
||||||
{ dbtSQLQuery = tableData
|
|
||||||
, dbtRowKey = (E.^. CourseId)
|
|
||||||
, dbtColonnade = colonnade
|
|
||||||
, dbtProj = return
|
|
||||||
, dbtSorting = Map.fromList
|
|
||||||
[ ( "term"
|
|
||||||
, SortColumn $ \course -> course E.^. CourseTerm
|
|
||||||
)
|
|
||||||
, ( "schoolshort"
|
|
||||||
, SortColumn $ \course -> course E.^. CourseSchool
|
|
||||||
)
|
|
||||||
, ( "course"
|
|
||||||
, SortColumn $ \course -> course E.^. CourseShorthand
|
|
||||||
)
|
|
||||||
, ( "deadline"
|
|
||||||
, SortColumn $ \course -> course E.^. CourseRegisterTo
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, dbtFilter = mempty {- [ ( "term"
|
|
||||||
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
|
||||||
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
||||||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
|
||||||
)
|
|
||||||
] -}
|
|
||||||
, dbtFilterUI = mempty
|
|
||||||
, dbtStyle = def
|
|
||||||
, dbtParams = def
|
|
||||||
, dbtIdent = "open-courses" :: Text
|
|
||||||
, dbtCsvEncode = noCsvEncode
|
|
||||||
, dbtCsvDecode = Nothing
|
|
||||||
}
|
|
||||||
$(widgetFile "home/openCourses")
|
|
||||||
|
|
||||||
homeUpcomingSheets :: UserId -> Widget
|
homeUpcomingSheets :: UserId -> Widget
|
||||||
homeUpcomingSheets uid = do
|
homeUpcomingSheets uid = do
|
||||||
cTime <- liftIO getCurrentTime
|
cTime <- liftIO getCurrentTime
|
||||||
@ -253,134 +126,137 @@ homeUpcomingSheets uid = do
|
|||||||
$(widgetFile "home/upcomingSheets")
|
$(widgetFile "home/upcomingSheets")
|
||||||
|
|
||||||
|
|
||||||
|
homeUpcomingExams :: UserId -> Widget
|
||||||
homeUpcomingExams :: UserId -> DB Widget
|
|
||||||
homeUpcomingExams uid = do
|
homeUpcomingExams uid = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let fortnight = addWeeks 2 now
|
((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
|
||||||
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
User {userWarningDays} <- get404 uid
|
||||||
examDBTable = DBTable{..}
|
let fortnight = addUTCTime userWarningDays now
|
||||||
where
|
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
||||||
-- for ease of refactoring:
|
examDBTable = DBTable{..}
|
||||||
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
where
|
||||||
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
-- for ease of refactoring:
|
||||||
lensCourse = _1
|
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||||
lensExam = _2
|
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||||
lensRegister = _3 . _Just
|
lensCourse = _1
|
||||||
lensOccurrence = _4 . _Just
|
lensExam = _2
|
||||||
|
lensRegister = _3 . _Just
|
||||||
|
lensOccurrence = _4 . _Just
|
||||||
|
|
||||||
dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
|
dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
|
||||||
E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
|
E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
|
||||||
E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
|
E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
|
||||||
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
||||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||||
E.where_ $ E.exists $ E.from $ \participant ->
|
E.where_ $ E.exists $ E.from $ \participant ->
|
||||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||||
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||||
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
|
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
|
||||||
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
|
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
|
||||||
E.&&. E.isNothing (register E.?. ExamRegistrationId)
|
E.&&. E.isNothing (register E.?. ExamRegistrationId)
|
||||||
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
|
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
|
||||||
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
|
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
|
||||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||||
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
||||||
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
||||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||||
earliestOccurrence = E.sub_select $ E.from $ \occ -> do
|
earliestOccurrence = E.sub_select $ E.from $ \occ -> do
|
||||||
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
||||||
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
||||||
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
||||||
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
|
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
|
||||||
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
|
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
|
||||||
-- E.&&. earliestOccurrence E.>=. E.just (E.val now)
|
-- E.&&. earliestOccurrence E.>=. E.just (E.val now)
|
||||||
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
|
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
|
||||||
return (course, exam, register, occurrence)
|
return (course, exam, register, occurrence)
|
||||||
dbtRowKey = queryExam >>> (E.^. ExamId)
|
dbtRowKey = queryExam >>> (E.^. ExamId)
|
||||||
dbtProj r@DBRow{ dbrOutput } = do
|
dbtProj r@DBRow{ dbrOutput } = do
|
||||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||||
Entity _ Course{..} = view lensCourse dbrOutput
|
Entity _ Course{..} = view lensCourse dbrOutput
|
||||||
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
|
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
|
||||||
return r
|
return r
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||||
msgCell courseTerm
|
msgCell courseTerm
|
||||||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||||
msgCell courseSchool
|
msgCell courseSchool
|
||||||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
||||||
-- continue here
|
-- continue here
|
||||||
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
|
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
|
||||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||||
Entity _ Course{..} = view lensCourse dbrOutput
|
Entity _ Course{..} = view lensCourse dbrOutput
|
||||||
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
|
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
|
||||||
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||||||
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
|
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
|
||||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||||
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
|
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
|
||||||
| Entity _ Exam{..} <- view lensExam dbrOutput
|
| Entity _ Exam{..} <- view lensExam dbrOutput
|
||||||
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
|
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
|
||||||
| otherwise -> mempty
|
| otherwise -> mempty
|
||||||
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
|
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
|
||||||
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
|
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
|
||||||
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||||
let Entity eId Exam{..} = view lensExam dbrOutput
|
let Entity eId Exam{..} = view lensExam dbrOutput
|
||||||
Entity _ Course{..} = view lensCourse dbrOutput
|
Entity _ Course{..} = view lensCourse dbrOutput
|
||||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||||||
if
|
if
|
||||||
| mayRegister -> do
|
| mayRegister -> do
|
||||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||||
return $ wrapForm examRegisterForm def
|
return $ wrapForm examRegisterForm def
|
||||||
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
||||||
, formEncoding = examRegisterEnctype
|
, formEncoding = examRegisterEnctype
|
||||||
, formSubmit = FormNoSubmit
|
, formSubmit = FormNoSubmit
|
||||||
}
|
}
|
||||||
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||||||
| otherwise -> return mempty
|
| otherwise -> return mempty
|
||||||
-}
|
-}
|
||||||
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||||
Entity _ Course{..} = view lensCourse dbrOutput
|
Entity _ Course{..} = view lensCourse dbrOutput
|
||||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||||
let isRegistered = has lensRegister dbrOutput
|
let isRegistered = has lensRegister dbrOutput
|
||||||
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
||||||
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||||
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
||||||
| otherwise -> return [whamlet|_{label}|]
|
| otherwise -> return [whamlet|_{label}|]
|
||||||
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
|
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
|
||||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||||
-> textCell examOccurrenceRoom
|
-> textCell examOccurrenceRoom
|
||||||
| otherwise -> mempty
|
| otherwise -> mempty
|
||||||
]
|
]
|
||||||
dbtSorting = Map.fromList
|
dbtSorting = Map.fromList
|
||||||
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
||||||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||||||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||||||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||||||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||||||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||||||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||||||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||||||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||||||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||||||
E.exists $ E.from $ \registration -> do
|
E.exists $ E.from $ \registration -> do
|
||||||
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
||||||
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||||
))
|
))
|
||||||
]
|
]
|
||||||
dbtFilter = Map.empty
|
dbtFilter = Map.empty
|
||||||
dbtFilterUI = const mempty
|
dbtFilterUI = const mempty
|
||||||
dbtStyle = def
|
dbtStyle = def
|
||||||
dbtParams = def
|
dbtParams = def
|
||||||
dbtIdent :: Text
|
dbtIdent :: Text
|
||||||
dbtIdent = "exams"
|
dbtIdent = "exams"
|
||||||
dbtCsvEncode = noCsvEncode
|
dbtCsvEncode = noCsvEncode
|
||||||
dbtCsvDecode = Nothing
|
dbtCsvDecode = Nothing
|
||||||
|
|
||||||
examDBTableValidator = def
|
examDBTableValidator = def
|
||||||
& defaultSorting [SortAscBy "time"]
|
& defaultSorting [SortAscBy "time"]
|
||||||
(Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable
|
|
||||||
return $(widgetFile "home/upcomingExams")
|
(, userWarningDays) <$> dbTable examDBTableValidator examDBTable
|
||||||
|
|
||||||
|
$(widgetFile "home/upcomingExams")
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -14,7 +14,6 @@ import qualified Data.Conduit.List as C
|
|||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Delete
|
import Handler.Utils.Delete
|
||||||
|
|||||||
@ -5,7 +5,6 @@ import Import
|
|||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
-- import Colonnade hiding (fromMaybe, singleton)
|
-- import Colonnade hiding (fromMaybe, singleton)
|
||||||
-- import Yesod.Colonnade
|
-- import Yesod.Colonnade
|
||||||
import Data.Monoid (Any(..))
|
import Data.Monoid (Any(..))
|
||||||
@ -25,6 +24,7 @@ data SettingsForm = SettingsForm
|
|||||||
, stgDate :: DateTimeFormat
|
, stgDate :: DateTimeFormat
|
||||||
, stgTime :: DateTimeFormat
|
, stgTime :: DateTimeFormat
|
||||||
, stgDownloadFiles :: Bool
|
, stgDownloadFiles :: Bool
|
||||||
|
, stgWarningDays :: NominalDiffTime
|
||||||
, stgNotificationSettings :: NotificationSettings
|
, stgNotificationSettings :: NotificationSettings
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -51,6 +51,9 @@ makeSettingForm template html = do
|
|||||||
<*> apopt checkBoxField (fslI MsgDownloadFiles
|
<*> apopt checkBoxField (fslI MsgDownloadFiles
|
||||||
& setTooltip MsgDownloadFilesTip
|
& setTooltip MsgDownloadFilesTip
|
||||||
) (stgDownloadFiles <$> template)
|
) (stgDownloadFiles <$> template)
|
||||||
|
<*> areq daysField (fslI MsgWarningDays
|
||||||
|
& setTooltip MsgWarningDaysTip
|
||||||
|
) (stgWarningDays <$> template)
|
||||||
<* aformSection MsgFormNotifications
|
<* aformSection MsgFormNotifications
|
||||||
<*> notificationForm (stgNotificationSettings <$> template)
|
<*> notificationForm (stgNotificationSettings <$> template)
|
||||||
return (result, widget) -- no validation required here
|
return (result, widget) -- no validation required here
|
||||||
@ -182,6 +185,7 @@ postProfileR = do
|
|||||||
, stgTime = userTimeFormat
|
, stgTime = userTimeFormat
|
||||||
, stgDownloadFiles = userDownloadFiles
|
, stgDownloadFiles = userDownloadFiles
|
||||||
, stgNotificationSettings = userNotificationSettings
|
, stgNotificationSettings = userNotificationSettings
|
||||||
|
, stgWarningDays = userWarningDays
|
||||||
}
|
}
|
||||||
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
||||||
|
|
||||||
@ -193,6 +197,7 @@ postProfileR = do
|
|||||||
, UserDateFormat =. stgDate
|
, UserDateFormat =. stgDate
|
||||||
, UserTimeFormat =. stgTime
|
, UserTimeFormat =. stgTime
|
||||||
, UserDownloadFiles =. stgDownloadFiles
|
, UserDownloadFiles =. stgDownloadFiles
|
||||||
|
, UserWarningDays =. stgWarningDays
|
||||||
, UserNotificationSettings =. stgNotificationSettings
|
, UserNotificationSettings =. stgNotificationSettings
|
||||||
]
|
]
|
||||||
when (stgMaxFavourties < userMaxFavourites) $ do
|
when (stgMaxFavourties < userMaxFavourites) $ do
|
||||||
|
|||||||
@ -49,11 +49,6 @@ import Data.Map (Map, (!))
|
|||||||
|
|
||||||
import Data.Monoid (Any(..))
|
import Data.Monoid (Any(..))
|
||||||
|
|
||||||
-- import Control.Lens
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
--import qualified Data.Aeson as Aeson
|
|
||||||
|
|
||||||
import Control.Monad.Random.Class (MonadRandom(..))
|
import Control.Monad.Random.Class (MonadRandom(..))
|
||||||
import Utils.Sql
|
import Utils.Sql
|
||||||
|
|
||||||
@ -186,7 +181,7 @@ getSheetListR tid ssh csh = do
|
|||||||
let
|
let
|
||||||
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
||||||
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
||||||
= [ sft | sft <- [minBound..maxBound]
|
= [ sft | sft <- universeF
|
||||||
, sft /= SheetExercise || hasExercise
|
, sft /= SheetExercise || hasExercise
|
||||||
, sft /= SheetHint || hasHint
|
, sft /= SheetHint || hasHint
|
||||||
, sft /= SheetSolution || hasSolution
|
, sft /= SheetSolution || hasSolution
|
||||||
@ -204,7 +199,7 @@ getSheetListR tid ssh csh = do
|
|||||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||||
|
|
||||||
sheetFilter :: SheetName -> DB Bool
|
sheetFilter :: SheetName -> DB Bool
|
||||||
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
|
sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
|
||||||
|
|
||||||
sheetCol = widgetColonnade . mconcat $
|
sheetCol = widgetColonnade . mconcat $
|
||||||
[ -- dbRow ,
|
[ -- dbRow ,
|
||||||
@ -220,9 +215,9 @@ getSheetListR tid ssh csh = do
|
|||||||
| let existingSFTs = hasSFT existFiles
|
| let existingSFTs = hasSFT existFiles
|
||||||
, sft <- [minBound..maxBound]
|
, sft <- [minBound..maxBound]
|
||||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||||
, let icn = toWidget $ sheetFile2markup sft
|
, let icn = toWgt $ sheetFile2markup sft
|
||||||
, let icnCell = if sft `elem` existingSFTs
|
, let icnCell = if sft `elem` existingSFTs
|
||||||
then linkEmptyCell link icn
|
then linkEitherCell link (icn, [whamlet| |])
|
||||||
else spacerCell
|
else spacerCell
|
||||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||||
|
|||||||
@ -6,8 +6,6 @@ import Import
|
|||||||
|
|
||||||
import Jobs
|
import Jobs
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
-- import Yesod.Form.Bootstrap3
|
-- import Yesod.Form.Bootstrap3
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|||||||
@ -11,8 +11,6 @@ import qualified Data.List.NonEmpty as NonEmpty
|
|||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
-- htmlField' moved to Handler.Utils.Form/Fields
|
-- htmlField' moved to Handler.Utils.Form/Fields
|
||||||
|
|||||||
@ -5,8 +5,6 @@ import Handler.Utils
|
|||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|||||||
@ -25,8 +25,6 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Aeson hiding (Result(..))
|
import Data.Aeson hiding (Result(..))
|
||||||
import Text.Hamlet (ihamlet)
|
import Text.Hamlet (ihamlet)
|
||||||
|
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Handler.Tutorial.Users
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
-- import Utils.DB
|
-- import Utils.DB
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|||||||
@ -13,8 +13,6 @@ import Handler.Utils.Invitations
|
|||||||
|
|
||||||
import qualified Auth.LDAP as Auth
|
import qualified Auth.LDAP as Auth
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|||||||
@ -4,8 +4,6 @@ module Handler.Utils
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as T
|
import qualified Data.Text.Encoding as T
|
||||||
import Data.Map ((!))
|
import Data.Map ((!))
|
||||||
@ -15,10 +13,6 @@ import Data.CaseInsensitive (original)
|
|||||||
-- import qualified Data.CaseInsensitive as CI
|
-- import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Conduit.List as Conduit
|
import qualified Data.Conduit.List as Conduit
|
||||||
|
|
||||||
import Language.Haskell.TH
|
|
||||||
import Language.Haskell.TH.Syntax (qRunIO)
|
|
||||||
-- import Language.Haskell.TH.Datatype
|
|
||||||
|
|
||||||
import Text.Hamlet (shamletFile)
|
import Text.Hamlet (shamletFile)
|
||||||
|
|
||||||
import Handler.Utils.DateTime as Handler.Utils
|
import Handler.Utils.DateTime as Handler.Utils
|
||||||
@ -32,12 +26,9 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
|
|||||||
import Handler.Utils.Sheet as Handler.Utils
|
import Handler.Utils.Sheet as Handler.Utils
|
||||||
import Handler.Utils.Mail as Handler.Utils
|
import Handler.Utils.Mail as Handler.Utils
|
||||||
import Handler.Utils.ContentDisposition as Handler.Utils
|
import Handler.Utils.ContentDisposition as Handler.Utils
|
||||||
|
import Handler.Utils.I18n as Handler.Utils
|
||||||
|
|
||||||
import System.Directory (listDirectory)
|
import System.FilePath.Posix (takeFileName)
|
||||||
import System.FilePath.Posix (takeBaseName, takeFileName)
|
|
||||||
|
|
||||||
import qualified Data.List as List
|
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
|
||||||
|
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
|
||||||
@ -218,36 +209,6 @@ warnTermDays tid timeNames = do
|
|||||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||||
|
|
||||||
-- | Add language dependent template files
|
|
||||||
--
|
|
||||||
-- For large files which are translated as a whole.
|
|
||||||
--
|
|
||||||
-- Argument musst be a directory under @/templates@,
|
|
||||||
-- which contains a file for each language,
|
|
||||||
-- eg. @imprint@ for choosing between
|
|
||||||
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
|
|
||||||
-- and @/templates/imprint/en.hamlet@
|
|
||||||
--
|
|
||||||
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
|
|
||||||
-- for directories)
|
|
||||||
-- @$ stack clean@ is required so new translations show up
|
|
||||||
i18nWidgetFile :: FilePath -> Q Exp
|
|
||||||
i18nWidgetFile basename = do
|
|
||||||
-- Construct list of available translations (@de@, @en@, ...) at compile time
|
|
||||||
let i18nDirectory = "templates" </> "i18n" </> basename
|
|
||||||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
|
||||||
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
|
|
||||||
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
|
|
||||||
|
|
||||||
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
|
||||||
ws <- newName "ws" -- Name for dispatch function
|
|
||||||
letE
|
|
||||||
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
|
|
||||||
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
|
|
||||||
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
|
||||||
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | return a value only if the current user ist authorized for a given route
|
-- | return a value only if the current user ist authorized for a given route
|
||||||
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
|
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
|
||||||
@ -264,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
|
|||||||
f <- messageLoggerSource app <$> readTVarIO loggerTVar
|
f <- messageLoggerSource app <$> readTVarIO loggerTVar
|
||||||
f loc src lvl str
|
f loc src lvl str
|
||||||
|
|
||||||
|
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
||||||
|
studyFeaturesWidget featId = do
|
||||||
|
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
||||||
|
|]
|
||||||
|
|
||||||
|
|||||||
@ -9,7 +9,6 @@ module Handler.Utils.Communication
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
import Control.Monad.Trans.Reader (mapReaderT)
|
import Control.Monad.Trans.Reader (mapReaderT)
|
||||||
|
|||||||
@ -5,8 +5,6 @@ module Handler.Utils.ContentDisposition
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
-- | Check whether the user's preference for files is inline-viewing or downloading
|
-- | Check whether the user's preference for files is inline-viewing or downloading
|
||||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||||
downloadFiles = do
|
downloadFiles = do
|
||||||
|
|||||||
@ -16,8 +16,6 @@ module Handler.Utils.DateTime
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Time.Zones
|
import Data.Time.Zones
|
||||||
import qualified Data.Time.Zones as TZ
|
import qualified Data.Time.Zones as TZ
|
||||||
|
|
||||||
|
|||||||
@ -17,8 +17,6 @@ module Handler.Utils.Delete
|
|||||||
import Import
|
import Import
|
||||||
import Handler.Utils.Form
|
import Handler.Utils.Form
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
|||||||
@ -12,8 +12,6 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
import qualified Database.Esqueleto.Internal.Sql as E
|
import qualified Database.Esqueleto.Internal.Sql as E
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|||||||
@ -40,13 +40,9 @@ import Control.Monad.Error.Class (MonadError(..))
|
|||||||
|
|
||||||
import Data.Either (partitionEithers)
|
import Data.Either (partitionEithers)
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Aeson (eitherDecodeStrict')
|
import Data.Aeson (eitherDecodeStrict')
|
||||||
import Data.Aeson.Text (encodeToLazyText)
|
import Data.Aeson.Text (encodeToLazyText)
|
||||||
|
|
||||||
import Data.Proxy
|
|
||||||
|
|
||||||
import qualified Text.Email.Validate as Email
|
import qualified Text.Email.Validate as Email
|
||||||
|
|
||||||
import Yesod.Core.Types (FileInfo(..))
|
import Yesod.Core.Types (FileInfo(..))
|
||||||
|
|||||||
@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils.Form.MassInput.Liveliness
|
import Handler.Utils.Form.MassInput.Liveliness
|
||||||
import Handler.Utils.Form.MassInput.TH
|
import Handler.Utils.Form.MassInput.TH
|
||||||
|
|
||||||
|
|||||||
@ -10,8 +10,6 @@ import qualified Data.Set as Set
|
|||||||
import Data.Map ((!))
|
import Data.Map ((!))
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
|
|
||||||
data OccurrenceScheduleKind = ScheduleKindWeekly
|
data OccurrenceScheduleKind = ScheduleKindWeekly
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
|||||||
43
src/Handler/Utils/I18n.hs
Normal file
43
src/Handler/Utils/I18n.hs
Normal file
@ -0,0 +1,43 @@
|
|||||||
|
module Handler.Utils.I18n
|
||||||
|
where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import Language.Haskell.TH
|
||||||
|
import Language.Haskell.TH.Syntax (qRunIO)
|
||||||
|
|
||||||
|
import qualified Data.List as List
|
||||||
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
|
|
||||||
|
import System.Directory (listDirectory)
|
||||||
|
import System.FilePath.Posix (takeBaseName)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Add language dependent template files
|
||||||
|
--
|
||||||
|
-- For large files which are translated as a whole.
|
||||||
|
--
|
||||||
|
-- Argument musst be a directory under @/templates@,
|
||||||
|
-- which contains a file for each language,
|
||||||
|
-- eg. @imprint@ for choosing between
|
||||||
|
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
|
||||||
|
-- and @/templates/imprint/en.hamlet@
|
||||||
|
--
|
||||||
|
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
|
||||||
|
-- for directories)
|
||||||
|
-- @$ stack clean@ is required so new translations show up
|
||||||
|
i18nWidgetFile :: FilePath -> Q Exp
|
||||||
|
i18nWidgetFile basename = do
|
||||||
|
-- Construct list of available translations (@de@, @en@, ...) at compile time
|
||||||
|
let i18nDirectory = "templates" </> "i18n" </> basename
|
||||||
|
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||||||
|
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
|
||||||
|
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
|
||||||
|
|
||||||
|
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
||||||
|
ws <- newName "ws" -- Name for dispatch function
|
||||||
|
letE
|
||||||
|
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
|
||||||
|
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
|
||||||
|
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
||||||
|
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
|
||||||
@ -16,7 +16,6 @@ module Handler.Utils.Invitations
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Lens
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
|
|
||||||
|
|||||||
@ -7,8 +7,6 @@ module Handler.Utils.Mail
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
|
|||||||
@ -39,8 +39,6 @@ import qualified Database.Esqueleto as E
|
|||||||
|
|
||||||
import qualified Data.Conduit.List as Conduit
|
import qualified Data.Conduit.List as Conduit
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
|
|
||||||
instance HasResolution prec => Pretty (Fixed prec) where
|
instance HasResolution prec => Pretty (Fixed prec) where
|
||||||
pretty = pretty . show
|
pretty = pretty . show
|
||||||
|
|||||||
@ -5,7 +5,6 @@ module Handler.Utils.SheetType
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.Monoid (Sum(..))
|
import Data.Monoid (Sum(..))
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||||
addBonusToPoints sts =
|
addBonusToPoints sts =
|
||||||
|
|||||||
@ -15,8 +15,6 @@ import Import hiding (joinPath)
|
|||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Control.Monad.State as State (StateT)
|
import Control.Monad.State as State (StateT)
|
||||||
import Control.Monad.State.Class as State
|
import Control.Monad.State.Class as State
|
||||||
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
||||||
|
|||||||
@ -2,7 +2,6 @@ module Handler.Utils.Table where
|
|||||||
-- General Utilities for Tables
|
-- General Utilities for Tables
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.Profunctor
|
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
|
||||||
@ -51,10 +50,12 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
|||||||
externalIds <- mapM (lift . toExternal) tdata
|
externalIds <- mapM (lift . toExternal) tdata
|
||||||
|
|
||||||
let
|
let
|
||||||
checkbox extId = Field parse view UrlEncoded
|
checkbox extId = Field{..}
|
||||||
where
|
where
|
||||||
parse [] _ = return $ Right Nothing
|
fieldEnctype = UrlEncoded
|
||||||
parse optlist _ = runExceptT $ do
|
|
||||||
|
fieldParse [] _ = return $ Right Nothing
|
||||||
|
fieldParse optlist _ = runExceptT $ do
|
||||||
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
|
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
|
||||||
case () of
|
case () of
|
||||||
_ | extId `elem` extIds
|
_ | extId `elem` extIds
|
||||||
@ -62,11 +63,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
|||||||
| otherwise
|
| otherwise
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
|
|
||||||
view _ name attributes val _ =
|
fieldView theId name attributes val _ =
|
||||||
-- TODO: move this to a *.hamlet file
|
-- TODO: move this to a *.hamlet file
|
||||||
[whamlet|
|
[whamlet|
|
||||||
<label style="display: block">
|
<label style="display: block">
|
||||||
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
<input ##{theId} type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
selectionIdent <- newFormIdent
|
selectionIdent <- newFormIdent
|
||||||
|
|||||||
@ -13,7 +13,6 @@ import Control.Monad.Trans.Writer (WriterT)
|
|||||||
|
|
||||||
import Text.Blaze (ToMarkup(..))
|
import Text.Blaze (ToMarkup(..))
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|
||||||
import Utils.Occurrences
|
import Utils.Occurrences
|
||||||
@ -101,6 +100,9 @@ msgCell = textCell . toMessage
|
|||||||
---------------------
|
---------------------
|
||||||
-- Icon cells
|
-- Icon cells
|
||||||
|
|
||||||
|
iconCell :: IsDBTable m a => Icon -> DBCell m a
|
||||||
|
iconCell = cell . toWidget . icon
|
||||||
|
|
||||||
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
|
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
|
||||||
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
|
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
|
||||||
|
|
||||||
|
|||||||
@ -12,14 +12,19 @@ import Import
|
|||||||
-- import Text.Blaze (ToMarkup(..))
|
-- import Text.Blaze (ToMarkup(..))
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
import qualified Database.Esqueleto.Utils as E
|
||||||
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
|
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import qualified Colonnade
|
||||||
|
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
||||||
|
|
||||||
|
import Text.Blaze (toMarkup)
|
||||||
|
|
||||||
|
|
||||||
--------------------------------
|
--------------------------------
|
||||||
-- Generic Columns
|
-- Generic Columns
|
||||||
@ -35,6 +40,36 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
-- * fltrXYZ : filter definitions for these columns
|
-- * fltrXYZ : filter definitions for these columns
|
||||||
-- * additional helper, such as default sorting
|
-- * additional helper, such as default sorting
|
||||||
|
|
||||||
|
type OpticColonnade focus
|
||||||
|
= forall m x r' h.
|
||||||
|
( IsDBTable m x
|
||||||
|
, FromSortable h
|
||||||
|
)
|
||||||
|
=> (forall focus'. Getting focus' r' focus)
|
||||||
|
-> Colonnade h r' (DBCell m x)
|
||||||
|
|
||||||
|
type OpticSortColumn' focus
|
||||||
|
= forall t sortingMap.
|
||||||
|
( IsMap sortingMap
|
||||||
|
, ContainerKey sortingMap ~ SortingKey
|
||||||
|
, MapValue sortingMap ~ SortColumn t
|
||||||
|
)
|
||||||
|
=> (forall focus'. Getting focus' t focus)
|
||||||
|
-> sortingMap
|
||||||
|
|
||||||
|
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
||||||
|
|
||||||
|
type OpticFilterColumn' t inp focus
|
||||||
|
= forall filterMap.
|
||||||
|
( IsMap filterMap
|
||||||
|
, ContainerKey filterMap ~ FilterKey
|
||||||
|
, MapValue filterMap ~ FilterColumn t
|
||||||
|
, IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
|
||||||
|
)
|
||||||
|
=> (forall focus'. Getting focus' t focus)
|
||||||
|
-> filterMap
|
||||||
|
|
||||||
|
type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus))
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
-- Numbers and Indices
|
-- Numbers and Indices
|
||||||
@ -44,6 +79,199 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
|
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
|
||||||
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
|
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
|
||||||
|
|
||||||
|
-----------
|
||||||
|
-- Terms --
|
||||||
|
-----------
|
||||||
|
|
||||||
|
colTermShort :: OpticColonnade TermId
|
||||||
|
colTermShort resultTid = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "term") (i18nCell MsgTerm)
|
||||||
|
body = i18nCell . ShortTermIdentifier . unTermKey . view resultTid
|
||||||
|
|
||||||
|
sortTerm :: OpticSortColumn TermId
|
||||||
|
sortTerm queryTid = singletonMap "term" . SortColumn $ view queryTid
|
||||||
|
|
||||||
|
fltrTerm :: OpticFilterColumn t TermId
|
||||||
|
fltrTerm queryTid = singletonMap "term" . FilterColumn $ mkExactFilter (view queryTid)
|
||||||
|
|
||||||
|
fltrTermUI :: DBFilterUI
|
||||||
|
fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTerm)
|
||||||
|
|
||||||
|
-------------
|
||||||
|
-- Schools --
|
||||||
|
-------------
|
||||||
|
|
||||||
|
colSchoolShort :: OpticColonnade SchoolId
|
||||||
|
colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "school") (i18nCell MsgSchool)
|
||||||
|
body = i18nCell . unSchoolKey . view resultSsh
|
||||||
|
|
||||||
|
sortSchool :: OpticSortColumn SchoolId
|
||||||
|
sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh
|
||||||
|
|
||||||
|
fltrSchool :: OpticFilterColumn t SchoolId
|
||||||
|
fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh)
|
||||||
|
|
||||||
|
fltrSchoolUI :: DBFilterUI
|
||||||
|
fltrSchoolUI mPrev = prismAForm (singletonFilter "school" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift schoolField) (fslI MsgSchool)
|
||||||
|
|
||||||
|
-----------------
|
||||||
|
-- Allocations --
|
||||||
|
-----------------
|
||||||
|
|
||||||
|
colAllocationName :: OpticColonnade AllocationName
|
||||||
|
colAllocationName resultName = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "allocation") (i18nCell MsgAllocationName)
|
||||||
|
body = i18nCell . view resultName
|
||||||
|
|
||||||
|
sortAllocationName :: OpticSortColumn AllocationName
|
||||||
|
sortAllocationName queryName = singletonMap "allocation" . SortColumn $ view queryName
|
||||||
|
|
||||||
|
fltrAllocation :: forall allocation t shorthand name.
|
||||||
|
( E.SqlProject Allocation AllocationShorthand allocation shorthand
|
||||||
|
, E.SqlProject Allocation AllocationName allocation name
|
||||||
|
, E.SqlString name, E.SqlString shorthand
|
||||||
|
)
|
||||||
|
=> OpticFilterColumn' t (Set (CI Text)) (E.SqlExpr allocation)
|
||||||
|
fltrAllocation query = singletonMap "allocation" . FilterColumn $ anyFilter
|
||||||
|
[ mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationShorthand) :: t -> Set (CI Text) -> E.SqlExpr (E.Value Bool)
|
||||||
|
, mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationName)
|
||||||
|
]
|
||||||
|
where
|
||||||
|
unSqlProject' :: E.SqlProject Allocation value allocation value' => value -> value'
|
||||||
|
unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation)
|
||||||
|
|
||||||
|
fltrAllocationUI :: DBFilterUI
|
||||||
|
fltrAllocationUI mPrev = prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (ciField :: Field _ AllocationName) (fslI MsgAllocation)
|
||||||
|
|
||||||
|
|
||||||
|
colAllocationShorthand :: OpticColonnade AllocationShorthand
|
||||||
|
colAllocationShorthand resultShort = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "allocation-short") (i18nCell MsgAllocation)
|
||||||
|
body = i18nCell . view resultShort
|
||||||
|
|
||||||
|
sortAllocationShorthand :: forall shorthand. PersistField shorthand => OpticSortColumn shorthand
|
||||||
|
sortAllocationShorthand queryShorthand = singletonMap "allocation-short" . SortColumn $ view queryShorthand
|
||||||
|
|
||||||
|
|
||||||
|
fltrAllocationActive :: UTCTime -- ^ current time
|
||||||
|
-> OpticFilterColumn' t (Last Bool) (E.SqlExpr (E.Entity Allocation))
|
||||||
|
fltrAllocationActive cTime queryAllocation = singletonMap "active" . FilterColumn $ \(view queryAllocation -> allocation) (Last criterion)
|
||||||
|
-> maybe (const E.true) ((E.==.) . E.val) criterion $ E.or
|
||||||
|
[ staffRegisterActive allocation
|
||||||
|
, staffAllocationActive allocation
|
||||||
|
, registerActive allocation
|
||||||
|
]
|
||||||
|
where
|
||||||
|
staffRegisterActive allocation
|
||||||
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffRegisterFrom)
|
||||||
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffRegisterTo)
|
||||||
|
staffAllocationActive allocation
|
||||||
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffAllocationFrom)
|
||||||
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffAllocationTo)
|
||||||
|
registerActive allocation
|
||||||
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom)
|
||||||
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationRegisterTo)
|
||||||
|
|
||||||
|
fltrAllocationActiveUI :: DBFilterUI
|
||||||
|
fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive)
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------
|
||||||
|
-- Course Applications --
|
||||||
|
-------------------------
|
||||||
|
|
||||||
|
colApplicationId :: OpticColonnade CourseApplicationId
|
||||||
|
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
||||||
|
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
|
||||||
|
|
||||||
|
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
||||||
|
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "points") (i18nCell MsgCourseApplicationRatingPoints)
|
||||||
|
body = views resultPoints $ maybe mempty i18nCell
|
||||||
|
|
||||||
|
sortApplicationRatingPoints :: OpticSortColumn (Maybe ExamGrade)
|
||||||
|
sortApplicationRatingPoints queryPoints = singletonMap "points" . SortColumn $ view queryPoints
|
||||||
|
|
||||||
|
fltrApplicationRatingPoints :: OpticFilterColumn t (Maybe ExamGrade)
|
||||||
|
fltrApplicationRatingPoints queryPoints = singletonMap "points" . FilterColumn . mkExactFilter $ view queryPoints
|
||||||
|
|
||||||
|
fltrApplicationRatingPointsUI :: DBFilterUI
|
||||||
|
fltrApplicationRatingPointsUI mPrev = prismAForm (singletonFilter "points" . maybePrism _PathPiece) mPrev $ aopt examGradeField (fslI MsgCourseApplicationRatingPoints)
|
||||||
|
|
||||||
|
colApplicationVeto :: OpticColonnade Bool
|
||||||
|
colApplicationVeto resultVeto = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "veto") (i18nCell MsgCourseApplicationVeto)
|
||||||
|
body = views resultVeto $ bool mempty (iconCell IconApplicationVeto)
|
||||||
|
|
||||||
|
sortApplicationVeto :: OpticSortColumn Bool
|
||||||
|
sortApplicationVeto queryVeto = singletonMap "veto" . SortColumn $ view queryVeto
|
||||||
|
|
||||||
|
fltrApplicationVeto :: OpticFilterColumn t Bool
|
||||||
|
fltrApplicationVeto queryVeto = singletonMap "veto" . FilterColumn . mkExactFilter $ view queryVeto
|
||||||
|
|
||||||
|
fltrApplicationVetoUI :: DBFilterUI
|
||||||
|
fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationVeto)
|
||||||
|
|
||||||
|
colApplicationRatingComment :: OpticColonnade (Maybe Text)
|
||||||
|
colApplicationRatingComment resultComment = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "comment") (i18nCell MsgApplicationRatingComment)
|
||||||
|
body = views resultComment . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
||||||
|
|
||||||
|
sortApplicationRatingComment :: OpticSortColumn (Maybe Text)
|
||||||
|
sortApplicationRatingComment queryComment = singletonMap "comment" . SortColumn $ view queryComment
|
||||||
|
|
||||||
|
fltrApplicationRatingComment :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
||||||
|
fltrApplicationRatingComment queryComment = singletonMap "comment" . FilterColumn . mkContainsFilterWith Just $ view queryComment
|
||||||
|
|
||||||
|
fltrApplicationRatingCommentUI :: DBFilterUI
|
||||||
|
fltrApplicationRatingCommentUI mPrev = prismAForm (singletonFilter "comment") mPrev $ aopt textField (fslI MsgApplicationRatingComment)
|
||||||
|
|
||||||
|
colApplicationText :: OpticColonnade (Maybe Text)
|
||||||
|
colApplicationText resultText = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "text") (i18nCell MsgCourseApplicationText)
|
||||||
|
body = views resultText . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
||||||
|
|
||||||
|
sortApplicationText :: OpticSortColumn (Maybe Text)
|
||||||
|
sortApplicationText queryText = singletonMap "text" . SortColumn $ view queryText
|
||||||
|
|
||||||
|
fltrApplicationText :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
||||||
|
fltrApplicationText queryText = singletonMap "text" . FilterColumn . mkContainsFilterWith Just $ view queryText
|
||||||
|
|
||||||
|
fltrApplicationTextUI :: DBFilterUI
|
||||||
|
fltrApplicationTextUI mPrev = prismAForm (singletonFilter "text") mPrev $ aopt textField (fslI MsgCourseApplicationText)
|
||||||
|
|
||||||
|
|
||||||
|
colApplicationFiles :: OpticColonnade (TermId, SchoolId, CourseShorthand, CourseApplicationId, Bool) -- ^ `Bool` controls whether link is shown, use result of determination whether files exist
|
||||||
|
colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "has-files") (i18nCell MsgCourseApplicationFiles)
|
||||||
|
body = views resultInfo $ \(tid, ssh, csh, appId, showLink) -> if
|
||||||
|
| showLink
|
||||||
|
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
|
||||||
|
cID <- encrypt appId
|
||||||
|
return $ CApplicationR tid ssh csh cID CAFilesR
|
||||||
|
| otherwise
|
||||||
|
-> mempty
|
||||||
|
|
||||||
|
sortApplicationFiles :: OpticSortColumn Bool
|
||||||
|
sortApplicationFiles queryFiles = singletonMap "has-files" . SortColumn $ view queryFiles
|
||||||
|
|
||||||
|
fltrApplicationFiles :: OpticFilterColumn t Bool
|
||||||
|
fltrApplicationFiles queryFiles = singletonMap "has-files" . FilterColumn . mkExactFilter $ view queryFiles
|
||||||
|
|
||||||
|
fltrApplicationFilesUI :: DBFilterUI
|
||||||
|
fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationFiles)
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
-- Files
|
-- Files
|
||||||
@ -92,9 +320,24 @@ defaultSortingByFileModification = defaultSorting [SortAscBy "time"]
|
|||||||
---------------
|
---------------
|
||||||
-- User names
|
-- User names
|
||||||
|
|
||||||
-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
|
colUserDisplayName :: OpticColonnade (UserDisplayName, UserSurname)
|
||||||
colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
colUserDisplayName resultDisplayName = Colonnade.singleton (fromSortable header) body
|
||||||
colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
where
|
||||||
|
header = Sortable (Just "user-name") (i18nCell MsgUserDisplayName)
|
||||||
|
body = views resultDisplayName $ cell . uncurry nameWidget
|
||||||
|
|
||||||
|
sortUserName' :: OpticSortColumn' (E.SqlExpr (E.Value UserDisplayName), E.SqlExpr (E.Value UserSurname))
|
||||||
|
sortUserName' queryDisplayName = singletonMap "user-name" . SortColumns $ \(view queryDisplayName -> (dn, sn))
|
||||||
|
-> [ SomeExprValue sn
|
||||||
|
, SomeExprValue dn
|
||||||
|
]
|
||||||
|
|
||||||
|
fltrUserName' :: OpticFilterColumn t UserDisplayName
|
||||||
|
fltrUserName' queryDisplayName = singletonMap "user-name" . FilterColumn . mkContainsFilter $ view queryDisplayName
|
||||||
|
|
||||||
|
fltrUserNameUI' :: DBFilterUI
|
||||||
|
fltrUserNameUI' mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgUserDisplayName)
|
||||||
|
|
||||||
|
|
||||||
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||||
colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
|
colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
|
||||||
@ -103,11 +346,12 @@ colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route
|
|||||||
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
|
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
|
||||||
|
|
||||||
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
||||||
-- TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
|
|
||||||
-- see also @defaultSortingName@
|
|
||||||
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||||
sortUserName queryUser = ("user-name", SortColumn $ toSortKey . queryUser)
|
sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
|
||||||
where toSortKey user = (user E.^. UserSurname) E.++. (user E.^. UserDisplayName)
|
[ SomeExprValue $ user E.^. UserSurname
|
||||||
|
, SomeExprValue $ user E.^. UserDisplayName
|
||||||
|
]
|
||||||
|
)
|
||||||
|
|
||||||
-- | Alias for sortUserName for consistency, since column comes in two variants
|
-- | Alias for sortUserName for consistency, since column comes in two variants
|
||||||
sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||||
@ -175,7 +419,25 @@ fltrUserNameEmailUI mPrev =
|
|||||||
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
-- Matriclenumber
|
-- Matriculation --
|
||||||
|
-------------------
|
||||||
|
|
||||||
|
colUserMatriculation :: OpticColonnade (Maybe UserMatriculation)
|
||||||
|
colUserMatriculation resultMatriculation = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "user-matriculation") (i18nCell MsgUserMatriculation)
|
||||||
|
body = views resultMatriculation . maybe mempty $ cell . toWidget
|
||||||
|
|
||||||
|
sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation)
|
||||||
|
sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation
|
||||||
|
|
||||||
|
fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation)))
|
||||||
|
fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWith Just $ view queryMatriculation
|
||||||
|
|
||||||
|
fltrUserMatriculationUI :: DBFilterUI
|
||||||
|
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgUserMatriculation)
|
||||||
|
|
||||||
|
|
||||||
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||||
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
||||||
|
|
||||||
@ -218,6 +480,109 @@ fltrUserEmailUI mPrev =
|
|||||||
-- Study features --
|
-- Study features --
|
||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
|
colStudyDegree :: OpticColonnade StudyDegree
|
||||||
|
colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "features-degree") (i18nCell MsgStudyFeatureDegree)
|
||||||
|
body = views resultDegree $ \StudyDegree{..}
|
||||||
|
-> cell . maybe (toWidget $ toMarkup studyDegreeKey) toWidget $ studyDegreeShorthand <|> studyDegreeName
|
||||||
|
|
||||||
|
sortStudyDegree :: forall studyDegree name shorthand key.
|
||||||
|
( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name
|
||||||
|
, E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand
|
||||||
|
, E.SqlProject StudyDegree StudyDegreeKey studyDegree key
|
||||||
|
, PersistField key, PersistField name, PersistField shorthand
|
||||||
|
)
|
||||||
|
=> OpticSortColumn' (E.SqlExpr studyDegree)
|
||||||
|
sortStudyDegree queryDegree = singletonMap "features-degree" . SortColumns $ \(view queryDegree -> degree)
|
||||||
|
-> [ SomeExprValue $ degree `E.sqlProject` StudyDegreeName
|
||||||
|
, SomeExprValue $ degree `E.sqlProject` StudyDegreeShorthand
|
||||||
|
, SomeExprValue $ degree `E.sqlProject` StudyDegreeKey
|
||||||
|
]
|
||||||
|
|
||||||
|
fltrStudyDegree :: forall studyDegree t name shorthand key.
|
||||||
|
( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name
|
||||||
|
, E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand
|
||||||
|
, E.SqlProject StudyDegree StudyDegreeKey studyDegree key
|
||||||
|
, E.SqlString name, E.SqlString shorthand, PersistField key
|
||||||
|
)
|
||||||
|
=> OpticFilterColumn' t (Set Text) (E.SqlExpr studyDegree)
|
||||||
|
fltrStudyDegree queryDegree = singletonMap "features-degree" . FilterColumn $ anyFilter
|
||||||
|
[ mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeName)
|
||||||
|
, mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeShorthand)
|
||||||
|
, mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyDegreeKey)) $ view queryDegree >>> (`E.sqlProject` StudyDegreeKey) >>> E.just
|
||||||
|
]
|
||||||
|
where
|
||||||
|
unSqlProject' :: E.SqlProject StudyDegree value studyDegree value' => value -> value'
|
||||||
|
unSqlProject' = E.unSqlProject (Proxy @StudyDegree) (Proxy @studyDegree)
|
||||||
|
|
||||||
|
fltrStudyDegreeUI :: DBFilterUI
|
||||||
|
fltrStudyDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
|
||||||
|
|
||||||
|
|
||||||
|
colStudyTerms :: OpticColonnade StudyTerms
|
||||||
|
colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "features-terms") (i18nCell MsgStudyTerm)
|
||||||
|
body = views resultTerms $ \StudyTerms{..}
|
||||||
|
-> cell . maybe (toWidget $ toMarkup studyTermsKey) toWidget $ studyTermsShorthand <|> studyTermsName
|
||||||
|
|
||||||
|
sortStudyTerms :: forall studyTerms name shorthand key.
|
||||||
|
( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name
|
||||||
|
, E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand
|
||||||
|
, E.SqlProject StudyTerms StudyTermsKey studyTerms key
|
||||||
|
, PersistField key, PersistField name, PersistField shorthand
|
||||||
|
)
|
||||||
|
=> OpticSortColumn' (E.SqlExpr studyTerms)
|
||||||
|
sortStudyTerms queryTerms = singletonMap "features-terms" . SortColumns $ \(view queryTerms -> terms)
|
||||||
|
-> [ SomeExprValue $ terms `E.sqlProject` StudyTermsName
|
||||||
|
, SomeExprValue $ terms `E.sqlProject` StudyTermsShorthand
|
||||||
|
, SomeExprValue $ terms `E.sqlProject` StudyTermsKey
|
||||||
|
]
|
||||||
|
|
||||||
|
fltrStudyTerms :: forall studyTerms t name shorthand key.
|
||||||
|
( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name
|
||||||
|
, E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand
|
||||||
|
, E.SqlProject StudyTerms StudyTermsKey studyTerms key
|
||||||
|
, E.SqlString name, E.SqlString shorthand, PersistField key
|
||||||
|
)
|
||||||
|
=> OpticFilterColumn' t (Set Text) (E.SqlExpr studyTerms)
|
||||||
|
fltrStudyTerms queryTerms = singletonMap "features-terms" . FilterColumn $ anyFilter
|
||||||
|
[ mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsName)
|
||||||
|
, mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsShorthand)
|
||||||
|
, mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyTermsKey)) $ view queryTerms >>> (`E.sqlProject` StudyTermsKey) >>> E.just
|
||||||
|
]
|
||||||
|
where
|
||||||
|
unSqlProject' :: E.SqlProject StudyTerms value studyTerms value' => value -> value'
|
||||||
|
unSqlProject' = E.unSqlProject (Proxy @StudyTerms) (Proxy @studyTerms)
|
||||||
|
|
||||||
|
fltrStudyTermsUI :: DBFilterUI
|
||||||
|
fltrStudyTermsUI mPrev = prismAForm (singletonFilter "features-terms") mPrev $ aopt textField (fslI MsgStudyTerm)
|
||||||
|
|
||||||
|
|
||||||
|
colStudyFeaturesSemester :: OpticColonnade Int
|
||||||
|
colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body
|
||||||
|
where
|
||||||
|
header = Sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge)
|
||||||
|
body = views resultSemester $ cell . toWidget . toMarkup
|
||||||
|
|
||||||
|
sortStudyFeaturesSemester :: forall semester. PersistField semester => OpticSortColumn semester
|
||||||
|
sortStudyFeaturesSemester querySemester = singletonMap "features-semester" . SortColumn $ view querySemester
|
||||||
|
|
||||||
|
fltrStudyFeaturesSemester :: forall studyFeatures t semester.
|
||||||
|
( E.SqlProject StudyFeatures Int studyFeatures semester
|
||||||
|
, PersistField semester
|
||||||
|
)
|
||||||
|
=> OpticFilterColumn' t (Set Int) (E.SqlExpr (E.Value semester))
|
||||||
|
fltrStudyFeaturesSemester querySemester = singletonMap "features-semester" . FilterColumn . mkExactFilterWith unSqlProject' $ view querySemester
|
||||||
|
where
|
||||||
|
unSqlProject' :: Int -> semester
|
||||||
|
unSqlProject' = E.unSqlProject (Proxy @StudyFeatures) (Proxy @studyFeatures)
|
||||||
|
|
||||||
|
fltrStudyFeaturesSemesterUI :: DBFilterUI
|
||||||
|
fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyFeatureAge)
|
||||||
|
|
||||||
|
|
||||||
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
||||||
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
|
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
|
||||||
|
|
||||||
@ -282,3 +647,64 @@ fltrDegree queryFeatures = ( "degree"
|
|||||||
fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||||
fltrDegreeUI mPrev =
|
fltrDegreeUI mPrev =
|
||||||
prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)
|
prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)
|
||||||
|
|
||||||
|
----------------------------
|
||||||
|
-- Colonnade manipulation --
|
||||||
|
----------------------------
|
||||||
|
|
||||||
|
imapColonnade :: (a -> c -> c)
|
||||||
|
-> Colonnade h a c
|
||||||
|
-> Colonnade h a c
|
||||||
|
-- ^ Not quite `imap`
|
||||||
|
imapColonnade f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones
|
||||||
|
where
|
||||||
|
dimapColonnade' OneColonnade{..} = OneColonnade
|
||||||
|
{ oneColonnadeEncode = \x -> f x $ oneColonnadeEncode x
|
||||||
|
, oneColonnadeHead
|
||||||
|
}
|
||||||
|
|
||||||
|
anchorColonnade :: forall h r' m a url.
|
||||||
|
( HasRoute UniWorX url
|
||||||
|
, IsDBTable m a
|
||||||
|
, HandlerSite m ~ UniWorX
|
||||||
|
)
|
||||||
|
=> (r' -> url)
|
||||||
|
-> Colonnade h r' (DBCell m a)
|
||||||
|
-> Colonnade h r' (DBCell m a)
|
||||||
|
anchorColonnade = anchorColonnadeM . (return .)
|
||||||
|
|
||||||
|
|
||||||
|
anchorColonnadeM :: forall h r' m a url.
|
||||||
|
( HasRoute UniWorX url
|
||||||
|
, IsDBTable m a
|
||||||
|
, HandlerSite m ~ UniWorX
|
||||||
|
)
|
||||||
|
=> (r' -> WidgetT UniWorX IO url)
|
||||||
|
-> Colonnade h r' (DBCell m a)
|
||||||
|
-> Colonnade h r' (DBCell m a)
|
||||||
|
anchorColonnadeM mkUrl = imapColonnade anchorColonnade'
|
||||||
|
where
|
||||||
|
anchorColonnade' :: r' -> DBCell m a -> DBCell m a
|
||||||
|
anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $
|
||||||
|
view (dbCell . _2) . anchorCellM (mkUrl inp) =<< act
|
||||||
|
|
||||||
|
emptyOpticColonnade :: forall h r' focus c.
|
||||||
|
( Monoid c
|
||||||
|
)
|
||||||
|
=> Fold r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results
|
||||||
|
-> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus`
|
||||||
|
-> Colonnade h r' c
|
||||||
|
-- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero or more than one values to `mempty`
|
||||||
|
emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column }
|
||||||
|
where
|
||||||
|
Colonnade oldColonnade = c $ singular l
|
||||||
|
-- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s)
|
||||||
|
-- because `Getter s a` is of kind @k -> *@ and can thus only be inspected
|
||||||
|
-- by @c@ through application which is precluded by the type of `Getter s a`
|
||||||
|
-- and the definition of `OneColonnade`
|
||||||
|
|
||||||
|
defaultColumn :: r' -> (r' -> c) -> c
|
||||||
|
defaultColumn x f = case x ^.. l of
|
||||||
|
[_] -> f x
|
||||||
|
_ -> mempty
|
||||||
|
|
||||||
|
|||||||
@ -1,5 +1,7 @@
|
|||||||
module Handler.Utils.Table.Pagination
|
module Handler.Utils.Table.Pagination
|
||||||
( module Handler.Utils.Table.Pagination.Types
|
( module Handler.Utils.Table.Pagination.Types
|
||||||
|
, dbFilterKey
|
||||||
|
, SomeExprValue(..)
|
||||||
, SortColumn(..), SortDirection(..)
|
, SortColumn(..), SortDirection(..)
|
||||||
, SortingSetting(..)
|
, SortingSetting(..)
|
||||||
, pattern SortAscBy, pattern SortDescBy
|
, pattern SortAscBy, pattern SortDescBy
|
||||||
@ -10,7 +12,7 @@ module Handler.Utils.Table.Pagination
|
|||||||
, DBCsvActionMode(..)
|
, DBCsvActionMode(..)
|
||||||
, DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
|
, DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
|
||||||
, DBTCsvEncode, DBTCsvDecode(..)
|
, DBTCsvEncode, DBTCsvDecode(..)
|
||||||
, DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
|
, DBTable(..), DBFilterUI, noCsvEncode, IsDBTable(..), DBCell(..)
|
||||||
, singletonFilter
|
, singletonFilter
|
||||||
, DBParams(..)
|
, DBParams(..)
|
||||||
, cellAttrs, cellContents
|
, cellAttrs, cellContents
|
||||||
@ -42,6 +44,7 @@ import Handler.Utils.Table.Pagination.CsvColumnExplanations
|
|||||||
import Handler.Utils.Form
|
import Handler.Utils.Form
|
||||||
import Handler.Utils.Csv
|
import Handler.Utils.Csv
|
||||||
import Handler.Utils.ContentDisposition
|
import Handler.Utils.ContentDisposition
|
||||||
|
import Handler.Utils.I18n
|
||||||
import Utils
|
import Utils
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
|
|
||||||
@ -80,8 +83,6 @@ import Text.Hamlet (hamletFile)
|
|||||||
|
|
||||||
import Data.Ratio ((%))
|
import Data.Ratio ((%))
|
||||||
|
|
||||||
import Control.Lens.Extras (is)
|
|
||||||
|
|
||||||
import Data.List (elemIndex)
|
import Data.List (elemIndex)
|
||||||
|
|
||||||
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
|
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
|
||||||
@ -104,7 +105,7 @@ import Data.Semigroup as Sem (Semigroup(..))
|
|||||||
|
|
||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
import Handler.Utils.DateTime (formatTimeW)
|
import Handler.Utils.DateTime (formatTimeRangeW)
|
||||||
import qualified Control.Monad.Catch as Catch
|
import qualified Control.Monad.Catch as Catch
|
||||||
|
|
||||||
|
|
||||||
@ -115,7 +116,26 @@ type Monoid' x = (Sem.Semigroup x, Monoid x)
|
|||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
||||||
|
|
||||||
|
instance PathPiece x => PathPiece (WithIdent x) where
|
||||||
|
toPathPiece (WithIdent ident x)
|
||||||
|
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
||||||
|
| otherwise = toPathPiece x
|
||||||
|
fromPathPiece txt = do
|
||||||
|
let sep = "-"
|
||||||
|
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
||||||
|
WithIdent <$> pure ident <*> fromPathPiece rest
|
||||||
|
|
||||||
|
|
||||||
|
dbFilterKey :: PathPiece dbtIdent => dbtIdent -> FilterKey -> Text
|
||||||
|
dbFilterKey ident = toPathPiece . WithIdent ident
|
||||||
|
|
||||||
|
|
||||||
|
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
|
||||||
|
|
||||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||||
|
| SortColumns { getSortColumns :: t -> [SomeExprValue] }
|
||||||
|
|
||||||
data SortDirection = SortAsc | SortDesc
|
data SortDirection = SortAsc | SortDesc
|
||||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||||
@ -132,9 +152,11 @@ deriveJSON defaultOptions
|
|||||||
{ constructorTagModifier = camelToPathPiece' 1
|
{ constructorTagModifier = camelToPathPiece' 1
|
||||||
} ''SortDirection
|
} ''SortDirection
|
||||||
|
|
||||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
|
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
|
||||||
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
|
sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
|
||||||
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
sqlSortDirection t (SortColumn e , SortDesc) = pure . E.desc $ e t
|
||||||
|
sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc v
|
||||||
|
sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v
|
||||||
|
|
||||||
|
|
||||||
data SortingSetting = SortingSetting
|
data SortingSetting = SortingSetting
|
||||||
@ -443,7 +465,7 @@ data DBStyle r = DBStyle
|
|||||||
}
|
}
|
||||||
|
|
||||||
data DBSTemplateMode r = DBSTDefault
|
data DBSTemplateMode r = DBSTDefault
|
||||||
| DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School))
|
| DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School)) (Traversal' r (Entity Allocation))
|
||||||
|
|
||||||
instance Default (DBStyle r) where
|
instance Default (DBStyle r) where
|
||||||
def = DBStyle
|
def = DBStyle
|
||||||
@ -485,17 +507,6 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
|
|||||||
fromOuter = Map.lookup key >=> listToMaybe
|
fromOuter = Map.lookup key >=> listToMaybe
|
||||||
|
|
||||||
|
|
||||||
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
|
||||||
|
|
||||||
instance PathPiece x => PathPiece (WithIdent x) where
|
|
||||||
toPathPiece (WithIdent ident x)
|
|
||||||
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
|
||||||
| otherwise = toPathPiece x
|
|
||||||
fromPathPiece txt = do
|
|
||||||
let sep = "-"
|
|
||||||
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
|
||||||
WithIdent <$> pure ident <*> fromPathPiece rest
|
|
||||||
|
|
||||||
type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
|
type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
|
||||||
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
|
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
|
||||||
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
|
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
|
||||||
@ -528,7 +539,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
|
|||||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||||
, dbtSorting :: Map SortingKey (SortColumn t)
|
, dbtSorting :: Map SortingKey (SortColumn t)
|
||||||
, dbtFilter :: Map FilterKey (FilterColumn t)
|
, dbtFilter :: Map FilterKey (FilterColumn t)
|
||||||
, dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
, dbtFilterUI :: DBFilterUI
|
||||||
, dbtStyle :: DBStyle r'
|
, dbtStyle :: DBStyle r'
|
||||||
, dbtParams :: DBParams m x
|
, dbtParams :: DBParams m x
|
||||||
, dbtCsvEncode :: DBTCsvEncode r' csv
|
, dbtCsvEncode :: DBTCsvEncode r' csv
|
||||||
@ -536,6 +547,8 @@ data DBTable m x = forall a r r' h i t k k' csv.
|
|||||||
, dbtIdent :: i
|
, dbtIdent :: i
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||||
|
|
||||||
noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void)
|
noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void)
|
||||||
noCsvEncode = Nothing
|
noCsvEncode = Nothing
|
||||||
|
|
||||||
@ -770,7 +783,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
|
|
||||||
piInput <- lift . runInputGetResult $ PaginationInput
|
piInput <- lift . runInputGetResult $ PaginationInput
|
||||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter)
|
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ dbFilterKey dbtIdent' k) dbtFilter)
|
||||||
<*> iopt pathPieceField (wIdent "pagesize")
|
<*> iopt pathPieceField (wIdent "pagesize")
|
||||||
<*> iopt intField (wIdent "page")
|
<*> iopt intField (wIdent "page")
|
||||||
|
|
||||||
@ -817,7 +830,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
|
tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
|
||||||
substPi = foldr (.) id
|
substPi = foldr (.) id
|
||||||
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
|
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
|
||||||
, foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
, foldr (.) id . map (\k -> setParams (dbFilterKey dbtIdent' k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
||||||
, setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
|
, setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
|
||||||
, setParam (wIdent "page") $ fmap toPathPiece piPage
|
, setParam (wIdent "page") $ fmap toPathPiece piPage
|
||||||
, setParam (wIdent "pagination") Nothing
|
, setParam (wIdent "pagination") Nothing
|
||||||
@ -851,6 +864,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
, formSubmit = FormSubmit
|
, formSubmit = FormSubmit
|
||||||
, formAnchor = Nothing :: Maybe Text
|
, formAnchor = Nothing :: Maybe Text
|
||||||
}
|
}
|
||||||
|
csvImportExplanation = modal [whamlet|_{MsgCsvImportExplanationLabel}|] $ Right $(i18nWidgetFile "table/csv-import-explanation")
|
||||||
csvColExplanations = case dbtCsvEncode of
|
csvColExplanations = case dbtCsvEncode of
|
||||||
(Just (Dict, _) :: DBTCsvEncode _ csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv
|
(Just (Dict, _) :: DBTCsvEncode _ csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
@ -861,7 +875,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
|
|
||||||
rows' <- E.select . E.from $ \t -> do
|
rows' <- E.select . E.from $ \t -> do
|
||||||
res <- dbtSQLQuery t
|
res <- dbtSQLQuery t
|
||||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
E.orderBy $ concatMap (sqlSortDirection t) psSorting'
|
||||||
case csvMode of
|
case csvMode of
|
||||||
FormSuccess DBCsvExport -> return ()
|
FormSuccess DBCsvExport -> return ()
|
||||||
FormSuccess DBCsvImport{} -> return ()
|
FormSuccess DBCsvImport{} -> return ()
|
||||||
@ -1043,12 +1057,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
attrs = sortableContent ^. cellAttrs
|
attrs = sortableContent ^. cellAttrs
|
||||||
piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
|
piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
|
||||||
case dbsTemplate of
|
case dbsTemplate of
|
||||||
DBSTCourse _ _ _ _ -> return $(widgetFile "table/course/header")
|
DBSTCourse{} -> return $(widgetFile "table/course/header")
|
||||||
DBSTDefault -> return $(widgetFile "table/cell/header")
|
DBSTDefault -> return $(widgetFile "table/cell/header")
|
||||||
in do
|
in do
|
||||||
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
||||||
case dbsTemplate of
|
case dbsTemplate of
|
||||||
DBSTCourse c l r s -> do
|
DBSTCourse c l r s a -> do
|
||||||
wRows <- forM rows $ \row' -> let
|
wRows <- forM rows $ \row' -> let
|
||||||
Course{..} = row' ^. c . _entityVal
|
Course{..} = row' ^. c . _entityVal
|
||||||
lecturerUsers = row' ^. l
|
lecturerUsers = row' ^. l
|
||||||
@ -1056,6 +1070,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
isRegistered = row' ^. r
|
isRegistered = row' ^. r
|
||||||
courseSchoolName = schoolName $ row' ^. s . _entityVal
|
courseSchoolName = schoolName $ row' ^. s . _entityVal
|
||||||
courseSemester = (termToText . unTermKey) courseTerm
|
courseSemester = (termToText . unTermKey) courseTerm
|
||||||
|
courseAllocation = row' ^? a
|
||||||
in return $(widgetFile "table/course/course-teaser")
|
in return $(widgetFile "table/course/course-teaser")
|
||||||
return $(widgetFile "table/course/colonnade")
|
return $(widgetFile "table/course/colonnade")
|
||||||
DBSTDefault -> do
|
DBSTDefault -> do
|
||||||
|
|||||||
@ -4,7 +4,7 @@ module Handler.Utils.Table.Pagination.Types
|
|||||||
( FilterKey, SortingKey
|
( FilterKey, SortingKey
|
||||||
, Sortable(..)
|
, Sortable(..)
|
||||||
, sortable
|
, sortable
|
||||||
, ToSortable(..)
|
, ToSortable(..), FromSortable(..)
|
||||||
, SortableP(..)
|
, SortableP(..)
|
||||||
, DBTableInvalid(..)
|
, DBTableInvalid(..)
|
||||||
) where
|
) where
|
||||||
@ -58,6 +58,19 @@ instance ToSortable Headless where
|
|||||||
pSortable = Nothing
|
pSortable = Nothing
|
||||||
|
|
||||||
|
|
||||||
|
class FromSortable s where
|
||||||
|
fromSortable :: forall a. Sortable a -> s a
|
||||||
|
|
||||||
|
instance FromSortable Sortable where
|
||||||
|
fromSortable = id
|
||||||
|
|
||||||
|
instance FromSortable Headed where
|
||||||
|
fromSortable Sortable{..} = Headed sortableContent
|
||||||
|
|
||||||
|
instance FromSortable Headless where
|
||||||
|
fromSortable _ = Headless
|
||||||
|
|
||||||
|
|
||||||
data DBTableInvalid = DBTIRowsMissing Int
|
data DBTableInvalid = DBTIRowsMissing Int
|
||||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
|
|
||||||
|
|||||||
@ -5,8 +5,6 @@ module Handler.Utils.Tokens
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Maybe (runMaybeT)
|
import Control.Monad.Trans.Maybe (runMaybeT)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -10,8 +10,6 @@ import qualified Database.Esqueleto as E
|
|||||||
import qualified Database.Esqueleto.Internal.Sql as E
|
import qualified Database.Esqueleto.Internal.Sql as E
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
|
|
||||||
fetchTutorialAux :: ( SqlBackendCanRead backend
|
fetchTutorialAux :: ( SqlBackendCanRead backend
|
||||||
, E.SqlSelect b a
|
, E.SqlSelect b a
|
||||||
|
|||||||
@ -10,6 +10,7 @@ import Model.Submission as Import
|
|||||||
import Model.Tokens as Import
|
import Model.Tokens as Import
|
||||||
import Utils.Tokens as Import
|
import Utils.Tokens as Import
|
||||||
import Utils.Frontend.Modal as Import
|
import Utils.Frontend.Modal as Import
|
||||||
|
import Utils.Lens as Import
|
||||||
|
|
||||||
import Settings as Import
|
import Settings as Import
|
||||||
import Settings.StaticFiles as Import
|
import Settings.StaticFiles as Import
|
||||||
|
|||||||
@ -3,7 +3,19 @@ module Import.NoModel
|
|||||||
, MForm
|
, MForm
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
|
import ClassyPrelude.Yesod as Import
|
||||||
|
hiding ( formatTime
|
||||||
|
, derivePersistFieldJSON
|
||||||
|
, getMessages, addMessage, addMessageI
|
||||||
|
, (.=)
|
||||||
|
, MForm
|
||||||
|
, Proxy
|
||||||
|
, foldlM
|
||||||
|
, static
|
||||||
|
, boolField, identifyForm
|
||||||
|
, HasHttpManager(..)
|
||||||
|
, embed
|
||||||
|
)
|
||||||
|
|
||||||
import Model.Types.TH.JSON as Import
|
import Model.Types.TH.JSON as Import
|
||||||
import Model.Types.TH.Wordlist as Import
|
import Model.Types.TH.Wordlist as Import
|
||||||
@ -60,7 +72,7 @@ import Ldap.Client.Pool as Import
|
|||||||
import System.Random as Import (Random(..))
|
import System.Random as Import (Random(..))
|
||||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||||
|
|
||||||
import Control.Monad.Morph as Import (MFunctor(..))
|
import Control.Monad.Morph as Import
|
||||||
import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
||||||
|
|
||||||
import Jose.Jwt as Import (Jwt)
|
import Jose.Jwt as Import (Jwt)
|
||||||
@ -80,6 +92,8 @@ import Data.Void as Import (Void)
|
|||||||
|
|
||||||
import Algebra.Lattice as Import hiding (meet, join)
|
import Algebra.Lattice as Import hiding (meet, join)
|
||||||
|
|
||||||
|
import Data.Proxy as Import (Proxy(..))
|
||||||
|
|
||||||
import Language.Haskell.TH.Instances as Import ()
|
import Language.Haskell.TH.Instances as Import ()
|
||||||
import Data.List.NonEmpty.Instances as Import ()
|
import Data.List.NonEmpty.Instances as Import ()
|
||||||
import Data.NonNull.Instances as Import ()
|
import Data.NonNull.Instances as Import ()
|
||||||
@ -114,6 +128,19 @@ import System.FilePath.Instances as Import ()
|
|||||||
import Net.IP.Instances as Import ()
|
import Net.IP.Instances as Import ()
|
||||||
import Data.Void.Instances as Import ()
|
import Data.Void.Instances as Import ()
|
||||||
import Crypto.Hash.Instances as Import ()
|
import Crypto.Hash.Instances as Import ()
|
||||||
|
import Colonnade.Instances as Import ()
|
||||||
|
import Data.Bool.Instances as Import ()
|
||||||
|
|
||||||
|
import Control.Lens as Import
|
||||||
|
hiding ( (<.>)
|
||||||
|
, universe
|
||||||
|
, cons, uncons, snoc, unsnoc, (<|)
|
||||||
|
, Index, index, (<.)
|
||||||
|
)
|
||||||
|
import Control.Lens.Extras as Import (is)
|
||||||
|
import Data.Set.Lens as Import
|
||||||
|
|
||||||
|
import Control.Arrow as Import (Kleisli(..))
|
||||||
|
|
||||||
|
|
||||||
import Control.Monad.Trans.RWS (RWST)
|
import Control.Monad.Trans.RWS (RWST)
|
||||||
|
|||||||
@ -6,8 +6,6 @@ module Jobs
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
|
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
|
||||||
import Jobs.Types (JobCtl(JobCtlQueue))
|
import Jobs.Types (JobCtl(JobCtlQueue))
|
||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
|
|||||||
@ -4,8 +4,6 @@ module Jobs.Crontab
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Jobs.Types
|
import Jobs.Types
|
||||||
|
|
||||||
|
|||||||
@ -9,8 +9,6 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Data.Bitraversable
|
import Data.Bitraversable
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -3,7 +3,6 @@ module Jobs.Handler.Invitation
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils.Mail
|
import Handler.Utils.Mail
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Jobs.Handler.SendCourseCommunication
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|||||||
@ -6,7 +6,6 @@ module Jobs.Handler.SendNotification.SubmissionRated
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Jobs.Handler.SendNotification.Utils
|
import Jobs.Handler.SendNotification.Utils
|
||||||
|
|
||||||
|
|||||||
@ -5,7 +5,6 @@ module Jobs.Handler.SendNotification.UserAuthModeUpdate
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Handler.Utils.Mail
|
import Handler.Utils.Mail
|
||||||
import Jobs.Handler.SendNotification.Utils
|
import Jobs.Handler.SendNotification.Utils
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Jobs.Handler.SendPasswordReset
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Users
|
import Handler.Utils.Users
|
||||||
|
|
||||||
|
|||||||
@ -8,8 +8,6 @@ import Handler.Utils.DateTime
|
|||||||
|
|
||||||
import Text.Shakespeare.Text
|
import Text.Shakespeare.Text
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
|
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
|
||||||
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
|
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
|
||||||
_mailTo .= [Address Nothing jEmail]
|
_mailTo .= [Address Nothing jEmail]
|
||||||
|
|||||||
@ -4,7 +4,6 @@ module Jobs.Handler.TransactionLog
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import hiding (currentYear)
|
import Import hiding (currentYear)
|
||||||
import Utils.Lens hiding ((<.))
|
|
||||||
import Handler.Utils.DateTime
|
import Handler.Utils.DateTime
|
||||||
|
|
||||||
import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
|
import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
|
||||||
|
|||||||
@ -14,8 +14,6 @@ import Data.Proxy (Proxy(..))
|
|||||||
|
|
||||||
import qualified Data.ByteArray as ByteArray
|
import qualified Data.ByteArray as ByteArray
|
||||||
|
|
||||||
import Utils.Lens
|
|
||||||
|
|
||||||
import Network.HTTP.Simple (httpJSON, httpLBS)
|
import Network.HTTP.Simple (httpJSON, httpLBS)
|
||||||
import qualified Network.HTTP.Simple as HTTP
|
import qualified Network.HTTP.Simple as HTTP
|
||||||
|
|
||||||
|
|||||||
@ -11,7 +11,6 @@ module Jobs.Queue
|
|||||||
import Import hiding ((<>))
|
import Import hiding ((<>))
|
||||||
|
|
||||||
import Utils.Sql
|
import Utils.Sql
|
||||||
import Utils.Lens
|
|
||||||
import Jobs.Types
|
import Jobs.Types
|
||||||
|
|
||||||
import Control.Monad.Trans.Writer (WriterT, runWriterT)
|
import Control.Monad.Trans.Writer (WriterT, runWriterT)
|
||||||
|
|||||||
@ -40,14 +40,6 @@ deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial
|
|||||||
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
|
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
|
||||||
deriving instance Eq (Unique Exam)
|
deriving instance Eq (Unique Exam)
|
||||||
|
|
||||||
instance Ord User where
|
|
||||||
compare User{userSurname=surnameA, userDisplayName=displayNameA, userEmail=emailA}
|
|
||||||
User{userSurname=surnameB, userDisplayName=displayNameB, userEmail=emailB}
|
|
||||||
= compare surnameA surnameB
|
|
||||||
<> compare displayNameA displayNameB
|
|
||||||
<> compare emailA emailB -- userEmail is unique, so this suffices
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
submissionRatingDone :: Submission -> Bool
|
submissionRatingDone :: Submission -> Bool
|
||||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||||
|
|||||||
@ -18,6 +18,17 @@ type Points = Centi
|
|||||||
|
|
||||||
type Email = Text
|
type Email = Text
|
||||||
|
|
||||||
|
type UserDisplayName = Text
|
||||||
|
type UserSurname = Text
|
||||||
|
type UserMatriculation = Text
|
||||||
|
|
||||||
|
type StudyDegreeName = Text
|
||||||
|
type StudyDegreeShorthand = Text
|
||||||
|
type StudyDegreeKey = Int
|
||||||
|
type StudyTermsName = Text
|
||||||
|
type StudyTermsShorthand = Text
|
||||||
|
type StudyTermsKey = Int
|
||||||
|
|
||||||
type SchoolName = CI Text
|
type SchoolName = CI Text
|
||||||
type SchoolShorthand = CI Text
|
type SchoolShorthand = CI Text
|
||||||
type CourseName = CI Text
|
type CourseName = CI Text
|
||||||
|
|||||||
@ -9,7 +9,6 @@ module Model.Types.DateTime
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoModel
|
import Import.NoModel
|
||||||
import Control.Lens
|
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|||||||
@ -14,7 +14,6 @@ import Model.Types.Common
|
|||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
import Control.Lens hiding (universe)
|
|
||||||
import Utils.Lens.TH
|
import Utils.Lens.TH
|
||||||
|
|
||||||
import qualified Data.Csv as Csv
|
import qualified Data.Csv as Csv
|
||||||
@ -217,8 +216,10 @@ type ExamResultPoints = ExamResult' Points
|
|||||||
type ExamResultGrade = ExamResult' ExamGrade
|
type ExamResultGrade = ExamResult' ExamGrade
|
||||||
type ExamResultPassed = ExamResult' ExamPassed
|
type ExamResultPassed = ExamResult' ExamPassed
|
||||||
|
|
||||||
instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where
|
type ExamResultPassedGrade = ExamResult' (Either ExamPassed ExamGrade)
|
||||||
|
|
||||||
|
instance Csv.ToField (Either ExamPassed ExamGrade) where
|
||||||
toField = either Csv.toField Csv.toField
|
toField = either Csv.toField Csv.toField
|
||||||
|
|
||||||
instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where
|
instance Csv.FromField (Either ExamPassed ExamGrade) where
|
||||||
parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
|
parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
|
||||||
|
|||||||
@ -8,7 +8,6 @@ module Model.Types.Misc
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoModel
|
import Import.NoModel
|
||||||
import Control.Lens
|
|
||||||
|
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
|
|
||||||
@ -19,6 +18,8 @@ import qualified Data.Text.Lens as Text
|
|||||||
data StudyFieldType = FieldPrimary | FieldSecondary
|
data StudyFieldType = FieldPrimary | FieldSecondary
|
||||||
deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
|
deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
|
||||||
derivePersistField "StudyFieldType"
|
derivePersistField "StudyFieldType"
|
||||||
|
instance Universe StudyFieldType
|
||||||
|
instance Finite StudyFieldType
|
||||||
|
|
||||||
|
|
||||||
data Theme
|
data Theme
|
||||||
|
|||||||
@ -11,8 +11,6 @@ import Import.NoModel
|
|||||||
import Model.Types.Common
|
import Model.Types.Common
|
||||||
import Utils.Lens.TH
|
import Utils.Lens.TH
|
||||||
|
|
||||||
import Control.Lens
|
|
||||||
import Control.Lens.Extras (is)
|
|
||||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||||
|
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
|
|||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user