Merge branch 'master' into info-lecturer
This commit is contained in:
Sarah Vaupel
commit
723ceaf1ed
134
CHANGELOG.md
134
CHANGELOG.md
@ -2,6 +2,140 @@
|
||||
|
||||
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.
|
||||
|
||||
### [7.9.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.9.0...v7.9.1) (2019-10-07)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* allow deregistering from full courses ([d7e1e67](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d7e1e67))
|
||||
|
||||
|
||||
|
||||
## [7.9.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.5...v7.9.0) (2019-10-05)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** show more information ([b7c54df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7c54df))
|
||||
|
||||
|
||||
|
||||
### [7.8.5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.4...v7.8.5) (2019-10-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* fix form-notification styling ([0226593](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0226593))
|
||||
|
||||
|
||||
|
||||
### [7.8.4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.3...v7.8.4) (2019-10-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course-user:** handle allocations when deregistering single users ([ef5bb70](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ef5bb70))
|
||||
|
||||
|
||||
|
||||
### [7.8.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.2...v7.8.3) (2019-10-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* typo ([a6e40f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a6e40f1))
|
||||
|
||||
|
||||
|
||||
### [7.8.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.1...v7.8.2) (2019-10-04)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **favourites:** always move current course up ([56d89d7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56d89d7))
|
||||
|
||||
|
||||
|
||||
### [7.8.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.0...v7.8.1) (2019-10-04)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **allocation:** fix allocation-results notifications ([ed700a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ed700a3))
|
||||
|
||||
|
||||
|
||||
## [7.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.7.0...v7.8.0) (2019-10-04)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* ordinalPriorities ([d4ab6f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d4ab6f6))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **course:** show direct registration dates ([8f284ac](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8f284ac))
|
||||
|
||||
|
||||
|
||||
## [7.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.6.0...v7.7.0) (2019-10-04)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** fingerprints & ordinal ratings ([60603cb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/60603cb))
|
||||
|
||||
|
||||
|
||||
## [7.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.5.0...v7.6.0) (2019-10-04)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** notification about finished allocation ([9323220](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9323220))
|
||||
* **allocations:** properly save allocation-relevant course-deregs ([7a759b1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a759b1))
|
||||
* **favourites:** usability improvements ([fccc2ea](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fccc2ea))
|
||||
|
||||
|
||||
|
||||
## [7.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.2...v7.5.0) (2019-10-03)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** auxilliaries for allocation-algo ([47bfd8d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/47bfd8d))
|
||||
* **allocations:** prototype assignment-algorithm ([0fcf48c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0fcf48c))
|
||||
|
||||
|
||||
|
||||
### [7.4.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.1...v7.4.2) (2019-10-01)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course-news:** prevent display of edit-functions unless auth'ed ([89cc9ad](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/89cc9ad))
|
||||
|
||||
|
||||
|
||||
### [7.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.0...v7.4.1) (2019-10-01)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course-news:** fix permissions ([9e5fde9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9e5fde9))
|
||||
|
||||
|
||||
|
||||
## [7.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.2...v7.4.0) (2019-10-01)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **course:** introduce CourseNews ([aa93b75](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/aa93b75))
|
||||
|
||||
|
||||
|
||||
### [7.3.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.1...v7.3.2) (2019-10-01)
|
||||
|
||||
|
||||
|
||||
@ -122,13 +122,23 @@ widget-memcached:
|
||||
expiration: "_env:MEMCACHEDEXPIRATION:3600"
|
||||
|
||||
user-defaults:
|
||||
max-favourites: 12
|
||||
theme: Default
|
||||
date-time-format: "%a %d %b %Y %R"
|
||||
date-format: "%d.%m.%Y"
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
max-favourites: 12
|
||||
max-favourite-terms: 2
|
||||
theme: Default
|
||||
date-time-format: "%a %d %b %Y %R"
|
||||
date-format: "%d.%m.%Y"
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
|
||||
# During central allocations lecturer-given ratings of applications (as
|
||||
# ExamGrades) are combined with a central priority.
|
||||
# This encodes the weight of the lecturer ratings on the same scale as the
|
||||
# centrally supplied priorities.
|
||||
allocation-grade-scale: 25
|
||||
# This encodes how many ordinal places lecturer ratings may move students up or
|
||||
# down when central priorities are supplied as ordered list.
|
||||
allocation-grade-ordinal-places: 3
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
ribbon: "_env:RIBBON:"
|
||||
|
||||
@ -56,6 +56,10 @@
|
||||
font-size: 18px;
|
||||
padding-left: 10px;
|
||||
}
|
||||
|
||||
.asidenav__box-subtitle {
|
||||
display: none;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -95,6 +99,14 @@
|
||||
border-bottom: 1px solid var(--color-grey);
|
||||
}
|
||||
|
||||
.asidenav__box-subtitle {
|
||||
color: var(--color-fontsec);
|
||||
font-size: 0.9rem;
|
||||
font-weight: 600;
|
||||
padding: 0 13px;
|
||||
margin: 3px 0;
|
||||
}
|
||||
|
||||
/* LOGO */
|
||||
|
||||
.asidenav__logo {
|
||||
@ -170,7 +182,7 @@
|
||||
position: absolute;
|
||||
bottom: -40px;
|
||||
right: 25px;
|
||||
opacity: 0.2;
|
||||
opacity: 0.1;
|
||||
|
||||
> img {
|
||||
width: 350px;
|
||||
@ -314,8 +326,16 @@
|
||||
color: var(--color-lightwhite);
|
||||
|
||||
&:hover {
|
||||
background-color: var(--color-dark);
|
||||
background-color: var(--color-darker);
|
||||
}
|
||||
|
||||
&::before {
|
||||
display: none;
|
||||
}
|
||||
}
|
||||
|
||||
.asidenav__box-subtitle {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.asidenav__link-shorthand {
|
||||
|
||||
@ -36,6 +36,10 @@ RegisterTo: Anmeldungen bis
|
||||
DeRegUntil: Abmeldungen bis
|
||||
RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden"
|
||||
|
||||
CourseRegistrationInterval: Anmeldung
|
||||
CourseDirectRegistrationInterval: Direkte Anmeldung
|
||||
CourseDeregisterUntil time@Text: Abmeldung nur bis #{time}
|
||||
|
||||
GenericKey: Schlüssel
|
||||
GenericShort: Kürzel
|
||||
GenericIsNew: Neu
|
||||
@ -378,12 +382,14 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
|
||||
UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert.
|
||||
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
|
||||
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
|
||||
UnauthorizedCourseNewsParticipant: Sie sind kein Teilnehmer dieser Veranstaltung.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
|
||||
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
|
||||
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben.
|
||||
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
|
||||
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
|
||||
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
|
||||
@ -474,7 +480,9 @@ LdapSynced: LDAP-Synchronisiert
|
||||
LdapSyncedBefore: Letzte LDAP-Synchronisation vor
|
||||
NoMatrikelKnown: Keine Matrikelnummer
|
||||
Theme: Oberflächen Design
|
||||
Favoriten: Anzahl gespeicherter Favoriten
|
||||
Favourites: Anzahl gespeicherter Favoriten
|
||||
FavouritesTip: Betrifft nur automatisch angelegte Favoriten („Kürzlich besucht“)
|
||||
FavouriteSemesters: Maximale Anzahl an Semestern in Seitenleiste
|
||||
Plugin: Plugin
|
||||
Ident: Identifikation
|
||||
LastLogin: Letzter Login
|
||||
@ -898,6 +906,7 @@ NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen f
|
||||
NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben
|
||||
NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden
|
||||
NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus
|
||||
NotificationTriggerAllocationResults: Plätze wurden für eine meiner Zentralanmeldungen verteilt
|
||||
NotificationTriggerExamOfficeExamResults: Ich kann neue Prüfungsergebnisse einsehen
|
||||
NotificationTriggerExamOfficeExamResultsChanged: Prüfungsergebnisse wurden verändert
|
||||
|
||||
@ -909,7 +918,8 @@ NotificationTriggerKindLecturer: Für Dozenten
|
||||
NotificationTriggerKindAdmin: Für Administratoren
|
||||
NotificationTriggerKindExamOffice: Für das Prüfungsamt
|
||||
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
|
||||
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen
|
||||
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten)
|
||||
NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen
|
||||
|
||||
CorrCreate: Abgaben erstellen
|
||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||
@ -1024,7 +1034,7 @@ MenuAllocationList: Zentralanmeldungen
|
||||
MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer
|
||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung
|
||||
MenuCourseCommunication: Kursmitteilung (E-Mail)
|
||||
MenuCourseApplications: Bewerbungen
|
||||
MenuCourseExamOffice: Prüfungsämter
|
||||
MenuTermShow: Semester
|
||||
@ -1088,6 +1098,8 @@ MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
|
||||
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
|
||||
MenuSchoolList: Institute
|
||||
MenuSchoolNew: Neues Institut anlegen
|
||||
MenuCourseNewsNew: Neue Kursnachricht
|
||||
MenuCourseNewsEdit: Kursnachricht bearbeiten
|
||||
|
||||
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
|
||||
@ -1127,6 +1139,7 @@ AuthTagRead: Zugriff ist nur lesend
|
||||
AuthTagWrite: Zugriff ist i.A. schreibend
|
||||
|
||||
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
|
||||
DeletePressButtonIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, bestätigen Sie dies bitte durch Drücken des untigen Knopfes.
|
||||
DeleteConfirmation: Bestätigung
|
||||
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
|
||||
|
||||
@ -1292,6 +1305,9 @@ HealthSMTPConnect: SMTP-Server kann erreicht werden
|
||||
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
|
||||
|
||||
CourseParticipantsHeading: Kursteilnehmer
|
||||
CourseParticipantsCount n@Int: #{n}
|
||||
CourseParticipantsCountOf n@Int m@Int: #{n} von #{m}
|
||||
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
|
||||
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
|
||||
@ -1629,7 +1645,10 @@ AllocationAppliedCourses: Bewerbungen
|
||||
AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben
|
||||
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
|
||||
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
|
||||
AllocationSchool: Institut
|
||||
AllocationSemester: Semester
|
||||
AllocationDescription: Beschreibung
|
||||
AllocationStaffDescription: Beschreibung für Dozenten
|
||||
AllocationStaffRegisterFrom: Eintragung der Kurse ab
|
||||
AllocationStaffRegister: Eintragung der Kurse
|
||||
AllocationRegisterFrom: Bewerbung ab
|
||||
@ -1638,6 +1657,13 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
|
||||
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
|
||||
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
|
||||
AllocationStaffAllocation: Bewertung der Bewerbungen
|
||||
AllocationRegisterByStaff: An- und Abmeldung durch Kursverwalter
|
||||
AllocationRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter ab
|
||||
AllocationRegisterByStaffTip: In diesem Zeitraum können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden.
|
||||
AllocationRegisterByStaffFromTip: Ab diesem Zeitpunkt können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden.
|
||||
AllocationRegisterByCourseFrom: Direkte An- und Abmeldung ab
|
||||
AllocationRegisterByCourseFromTip: Frühestens ab diesem Zeitpunkt ist die eigentständige An- und Abmeldung zu und von den Kursen, die an der Zentralanmeldung teilnehmen, möglich. Kontrolle über die genauen Fristen haben die Kursverwalter.
|
||||
AllocationOverrideDeregister: Abmeldung von den Kursen nur bis
|
||||
AllocationProcess: Platzvergabe
|
||||
AllocationNoApplication: Keine Bewerbung
|
||||
AllocationPriority: Priorität
|
||||
@ -1832,3 +1858,45 @@ CsvQuoteMinimal: Nur wenn nötig
|
||||
CsvQuoteAll: Immer
|
||||
CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst
|
||||
CsvChangeOptionsLabel: Export-Optionen
|
||||
|
||||
CourseNews: Aktuelles
|
||||
CourseNewsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand newsTitle@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle}
|
||||
CourseNewsFiles: Dateien
|
||||
CourseNewsLastEdited time@Text: Zuletzt verändert: #{time}
|
||||
CourseNewsActionEdit: Bearbeiten
|
||||
CourseNewsActionDelete: Löschen
|
||||
CourseNewsActionCreate: Neue Nachricht
|
||||
CourseMaterial: Material
|
||||
CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich
|
||||
CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
|
||||
|
||||
CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte.
|
||||
CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten
|
||||
CourseNewsTitle: Titel
|
||||
CourseNewsSummary: Zusammenfassung
|
||||
CourseNewsSummaryTip: Wenn angegeben, wird auf der Kursübersichtsseite, platzsparend, nur die Zusammenfassung angezeigt und der Inhalt in ein Popup ausgelagert
|
||||
CourseNewsContent: Inhalt
|
||||
CourseNewsParticipantsOnly: Nur für Kursteilnehmer
|
||||
CourseNewsVisibleFrom: Sichtbar ab
|
||||
CourseNewsCreated: Kursnachricht erfolgreich angelegt
|
||||
CourseNewsEdited: Kursnachricht erfolgreich editiert
|
||||
CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen?
|
||||
CourseNewsDeleted: Kursnachricht erfolgreich gelöscht
|
||||
|
||||
CourseDeregistrationAllocationLog: Ihr Platz in diesem Kurs stammt aus einer Zentralanmeldung. Wenn Sie sich vom Kurs abmelden wird dieser Umstand permanent im System gespeichert und kann Sie u.U. bei zukünftigen Zentralanmeldungen benachteiligen. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden.
|
||||
CourseDeregistrationAllocationReason: Grund
|
||||
CourseDeregistrationAllocationReasonTip: Der angegebene Grund wird permanent im System hinterlegt und ist i.A. einziger Anhaltspunkt zur Schlichtung etwaiger Konflikte
|
||||
CourseDeregistrationAllocationShouldLog: Selbstverschuldet
|
||||
CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist.
|
||||
|
||||
MailSubjectAllocationResults allocation@AllocationName: Plätze für Zentralanmeldung „#{allocation}“ wurden verteilt
|
||||
AllocationResultsLecturer: Es wurden Plätze zugewiesen, wie folgt:
|
||||
AllocationResultLecturer csh@CourseShorthand count@Int64: #{count} Teilnehmer für #{csh}
|
||||
AllocationResultsStudent: Sie haben Plätze erhalten in:
|
||||
AllocationNoResultsStudent: Sie haben leider keine Plätze erhalten.
|
||||
AllocationResultStudent csh@CourseShorthand: Sie haben einen Platz in #{csh} erhalten.
|
||||
|
||||
FavouriteVisited: Kürzlich besucht
|
||||
FavouriteParticipant: Ihre Kurse
|
||||
FavouriteManual: Favoriten
|
||||
FavouriteCurrent: Aktueller Kurs
|
||||
|
||||
@ -21,6 +21,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
fingerprint AllocationFingerprint Maybe
|
||||
matchingLog FileId Maybe
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show Eq Ord Generic
|
||||
@ -35,6 +37,7 @@ AllocationUser
|
||||
allocation AllocationId
|
||||
user UserId
|
||||
totalCourses Natural -- number of total allocated courses for this user must be <= than this number
|
||||
priority AllocationPriority Maybe
|
||||
UniqueAllocationUser allocation user
|
||||
|
||||
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
|
||||
@ -35,12 +35,6 @@ CourseEdit -- who edited when a row in table "Course", kept indef
|
||||
user UserId
|
||||
time UTCTime
|
||||
course CourseId
|
||||
CourseFavourite -- which user accessed which course when, only displayed to user for convenience;
|
||||
user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User"
|
||||
time UTCTime -- oldest is removed first
|
||||
course CourseId
|
||||
UniqueCourseFavourite user course
|
||||
deriving Show
|
||||
Lecturer -- course ownership
|
||||
user UserId
|
||||
course CourseId
|
||||
@ -51,7 +45,7 @@ CourseParticipant -- course enrolement
|
||||
user UserId
|
||||
registration UTCTime -- time of last enrolement for this course
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
allocated Bool default=false -- participant was centrally allocated
|
||||
allocated AllocationId Maybe -- participant was centrally allocated
|
||||
UniqueParticipant user course
|
||||
-- Replace the last two by the following, once an audit log is available
|
||||
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
|
||||
@ -76,20 +70,3 @@ CourseUserExamOfficeOptOut
|
||||
user UserId
|
||||
school SchoolId
|
||||
UniqueCourseUserExamOfficeOptOut course user school
|
||||
|
||||
CourseApplication
|
||||
course CourseId
|
||||
user UserId
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
text Text Maybe -- free text entered by user
|
||||
ratingVeto Bool default=false
|
||||
ratingPoints ExamGrade Maybe
|
||||
ratingComment Text Maybe
|
||||
allocation AllocationId Maybe
|
||||
allocationPriority Natural Maybe
|
||||
time UTCTime default=now()
|
||||
ratingTime UTCTime Maybe
|
||||
CourseApplicationFile
|
||||
application CourseApplicationId
|
||||
file FileId
|
||||
UniqueApplicationFile application file
|
||||
16
models/courses/applications.model
Normal file
16
models/courses/applications.model
Normal file
@ -0,0 +1,16 @@
|
||||
CourseApplication
|
||||
course CourseId
|
||||
user UserId
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
text Text Maybe -- free text entered by user
|
||||
ratingVeto Bool default=false
|
||||
ratingPoints ExamGrade Maybe
|
||||
ratingComment Text Maybe
|
||||
allocation AllocationId Maybe
|
||||
allocationPriority Natural Maybe
|
||||
time UTCTime default=now()
|
||||
ratingTime UTCTime Maybe
|
||||
CourseApplicationFile
|
||||
application CourseApplicationId
|
||||
file FileId
|
||||
UniqueApplicationFile application file
|
||||
10
models/courses/favourite.model
Normal file
10
models/courses/favourite.model
Normal file
@ -0,0 +1,10 @@
|
||||
CourseFavourite -- which user accessed which course when, only displayed to user for convenience;
|
||||
user UserId
|
||||
course CourseId
|
||||
reason FavouriteReason
|
||||
lastVisit UTCTime
|
||||
UniqueCourseFavourite user course
|
||||
CourseNoFavourite
|
||||
user UserId
|
||||
course CourseId
|
||||
UniqueCourseNoFavourite user course
|
||||
@ -9,4 +9,5 @@ Material -- course material for disemination to course participants
|
||||
deriving Generic
|
||||
MaterialFile -- a file that is part of a material distribution
|
||||
material MaterialId
|
||||
file FileId
|
||||
file FileId
|
||||
UniqueMaterialFile material file
|
||||
12
models/courses/news.model
Normal file
12
models/courses/news.model
Normal file
@ -0,0 +1,12 @@
|
||||
CourseNews
|
||||
course CourseId
|
||||
visibleFrom UTCTime Maybe
|
||||
participantsOnly Bool
|
||||
title Text Maybe
|
||||
content Html
|
||||
summary Html Maybe
|
||||
lastEdit UTCTime
|
||||
CourseNewsFile
|
||||
news CourseNewsId
|
||||
file FileId
|
||||
UniqueCourseNewsFile news file
|
||||
@ -21,7 +21,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||
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 non-manual entries in favourites bar (pruned only if below a set importance threshold)
|
||||
maxFavouriteTerms Int default=2 -- max number of term-sections in favourites bar
|
||||
theme Theme default='Default' -- Color-theme of the frontend; user-defined
|
||||
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
|
||||
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "7.3.2",
|
||||
"version": "7.9.1",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "7.3.2",
|
||||
"version": "7.9.1",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 7.3.2
|
||||
version: 7.9.1
|
||||
|
||||
dependencies:
|
||||
- base >=4.9.1.0 && <5
|
||||
@ -138,6 +138,8 @@ dependencies:
|
||||
- deepseq
|
||||
- multiset
|
||||
- retry
|
||||
- generic-lens
|
||||
- array
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
@ -202,6 +204,7 @@ ghc-options:
|
||||
- -fno-warn-partial-type-signatures
|
||||
- -fno-max-relevant-binds
|
||||
- -j
|
||||
- -freduction-depth=0
|
||||
|
||||
when:
|
||||
- condition: flag(pedantic)
|
||||
|
||||
10
routes
10
routes
@ -104,7 +104,8 @@
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time
|
||||
/favourite CFavouriteR POST
|
||||
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registered !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time
|
||||
/register-template CRegisterTemplateR GET !free
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite CLecInviteR GET POST
|
||||
@ -179,6 +180,13 @@
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
||||
/files CAFilesR GET !self !lecturerANDstaff-time
|
||||
!/news/add CNewsNewR GET POST
|
||||
/news/#CryptoUUIDCourseNews CourseNewsR:
|
||||
/ CNShowR GET !timeANDparticipant
|
||||
/edit CNEditR GET POST
|
||||
/delete CNDeleteR GET POST
|
||||
!/download CNArchiveR GET !timeANDparticipant
|
||||
!/download/*FilePath CNFileR GET !timeANDparticipant
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
|
||||
@ -48,6 +48,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''AllocationId
|
||||
, ''CourseApplicationId
|
||||
, ''CourseId
|
||||
, ''CourseNewsId
|
||||
]
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
|
||||
@ -156,8 +156,20 @@ deriving instance Generic CourseApplicationR
|
||||
deriving instance Generic AllocationR
|
||||
deriving instance Generic SchoolR
|
||||
deriving instance Generic ExamOfficeR
|
||||
deriving instance Generic CourseNewsR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
data RouteChildren
|
||||
type instance Children RouteChildren a = ChildrenRouteChildren a
|
||||
type family ChildrenRouteChildren a where
|
||||
ChildrenRouteChildren (Route EmbeddedStatic) = '[]
|
||||
ChildrenRouteChildren (Route Auth) = '[]
|
||||
ChildrenRouteChildren UUID = '[]
|
||||
ChildrenRouteChildren (Key a) = '[]
|
||||
ChildrenRouteChildren (CI a) = '[]
|
||||
|
||||
ChildrenRouteChildren a = Children ChGeneric a
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB = YesodDB UniWorX
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
|
||||
@ -188,6 +200,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
|
||||
pattern CApplicationR tid ssh csh appId ptn
|
||||
= CourseR tid ssh csh (CourseApplicationR appId ptn)
|
||||
|
||||
pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX
|
||||
pattern CNewsR tid ssh csh nId ptn
|
||||
= CourseR tid ssh csh (CourseNewsR nId ptn)
|
||||
|
||||
|
||||
pluralDE :: (Eq a, Num a)
|
||||
@ -317,6 +333,7 @@ embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''SchoolFunction id
|
||||
embedRenderMessage ''UniWorX ''CsvPreset id
|
||||
embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
|
||||
embedRenderMessage ''UniWorX ''FavouriteReason id
|
||||
|
||||
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
||||
|
||||
@ -934,6 +951,13 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
&& NTop systemMessageTo >= cTime
|
||||
return Authorized
|
||||
|
||||
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
||||
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
guard $ NTop courseNewsVisibleFrom <= cTime
|
||||
return Authorized
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthTime r
|
||||
tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
@ -985,8 +1009,8 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
|
||||
mba <- mbAllocation tid ssh csh
|
||||
case mba of
|
||||
Just (_, Allocation{..})
|
||||
| NTop allocationStaffRegisterTo <= NTop (Just now)
|
||||
|| NTop allocationStaffRegisterFrom >= NTop (Just now)
|
||||
| NTop allocationRegisterByStaffTo <= NTop (Just now)
|
||||
|| NTop allocationRegisterByStaffFrom >= NTop (Just now)
|
||||
-> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
|
||||
_other -> return Authorized
|
||||
|
||||
@ -995,7 +1019,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
|
||||
mba <- mbAllocation tid ssh csh
|
||||
case mba of
|
||||
Just (_, Allocation{..})
|
||||
| NTop allocationRegisterByStaffTo <= NTop (Just now)
|
||||
| NTop allocationRegisterByStaffTo <= NTop (Just now)
|
||||
|| NTop allocationRegisterByStaffFrom >= NTop (Just now)
|
||||
-> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
|
||||
_other -> return Authorized
|
||||
@ -1104,81 +1128,96 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
|
||||
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
|
||||
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
|
||||
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
-- participant is currently registered
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant has at least one submission
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is member of a submissionGroup
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a sheet corrector
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a tutorial user
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is tutor for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is lecturer for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is applicant for this course
|
||||
$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.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
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)
|
||||
tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsParticipant) $ do
|
||||
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
|
||||
if | courseNewsParticipantsOnly -> do
|
||||
uid <- hoistMaybe mAuthId
|
||||
exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid
|
||||
| otherwise
|
||||
-> return Authorized
|
||||
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
isCourseParticipant tid ssh csh participant
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
|
||||
where
|
||||
isCourseParticipant tid ssh csh participant = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
|
||||
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
|
||||
-- participant is currently registered
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant has at least one submission
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is member of a submissionGroup
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a sheet corrector
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a tutorial user
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is tutor for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is lecturer for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is applicant for this course
|
||||
$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.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
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)
|
||||
|
||||
return ()
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -1484,24 +1523,22 @@ instance Yesod UniWorX where
|
||||
now <- liftIO $ getCurrentTime
|
||||
uid <- MaybeT $ liftHandler maybeAuthId
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
user <- MaybeT $ get uid
|
||||
let courseFavourite = CourseFavourite uid now cid
|
||||
User{userMaxFavourites} <- MaybeT $ get uid
|
||||
|
||||
$logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
|
||||
-- update Favourites
|
||||
void . lift $ upsertBy
|
||||
(UniqueCourseFavourite uid cid)
|
||||
courseFavourite
|
||||
[CourseFavouriteTime =. now]
|
||||
(CourseFavourite uid cid FavouriteVisited now)
|
||||
[CourseFavouriteLastVisit =. now]
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- lift $ selectKeysList
|
||||
[ CourseFavouriteUser ==. uid]
|
||||
[ Desc CourseFavouriteTime
|
||||
, OffsetBy $ userMaxFavourites user
|
||||
]
|
||||
lift . forM_ oldFavs $ \fav -> do
|
||||
$logDebugS "updateFavourites" "Deleting old favourite."
|
||||
delete fav
|
||||
oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
|
||||
let deleteFavs = oldFavs
|
||||
& sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
|
||||
& drop userMaxFavourites
|
||||
& filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
|
||||
& map entityKey
|
||||
unless (null deleteFavs) $
|
||||
lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
|
||||
_other -> return ()
|
||||
normalizeRouteMiddleware :: Handler a -> Handler a
|
||||
normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
@ -1648,24 +1685,61 @@ siteLayout' headingOverride widget = do
|
||||
|
||||
isAuth <- isJust <$> maybeAuthId
|
||||
|
||||
-- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
|
||||
(favourites', currentTheme) <- do
|
||||
-- Lookup Favourites & Theme if possible
|
||||
(favourites', maxFavouriteTerms, currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
case muid of
|
||||
Nothing -> return ([],userDefaultTheme)
|
||||
(Just (uid,user)) -> do
|
||||
favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
|
||||
E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
|
||||
E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
|
||||
E.orderBy [ E.asc $ course E.^. CourseShorthand ]
|
||||
return course
|
||||
return (favs, userTheme user)
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
|
||||
favCourses <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
|
||||
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
|
||||
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
|
||||
|
||||
let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
|
||||
isCurrent
|
||||
| Just (CourseR tid ssh csh _) <- mcurrentRoute
|
||||
= course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
| otherwise
|
||||
= E.false
|
||||
notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
|
||||
E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
|
||||
E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
|
||||
isParticipant = E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
|
||||
isLecturer = E.exists . E.from $ \lecturer ->
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
|
||||
isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
|
||||
E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
|
||||
isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
|
||||
isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
|
||||
|
||||
reason = E.case_
|
||||
[ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent
|
||||
, E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
|
||||
] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
|
||||
|
||||
E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
|
||||
|
||||
return (course, reason)
|
||||
|
||||
return ( favCourses
|
||||
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
|
||||
, maybe userDefaultTheme userTheme $ view _2 <$> muid
|
||||
)
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..}, E.Value mFavourite)
|
||||
-> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
favouriteReason = fromMaybe FavouriteCurrent mFavourite
|
||||
in do
|
||||
items <- filterM menuItemAccessCallback (pageActions courseRoute)
|
||||
items' <- forM items $ \i -> (i, ) <$> toTextUrl i
|
||||
return (c, courseRoute, items')
|
||||
return (c, courseRoute, items', favouriteReason)
|
||||
|
||||
mmsgs <- if
|
||||
| isModal -> getMessages
|
||||
@ -1682,9 +1756,11 @@ siteLayout' headingOverride widget = do
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
|
||||
in \r -> Just r == highR
|
||||
favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
||||
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
|
||||
favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
|
||||
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(MenuItem, Text)], FavouriteReason)]
|
||||
favouriteTermReason tid favReason' = favourites
|
||||
& filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason')
|
||||
& sortOn (\(Course{..}, _, _, _) -> courseName)
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
@ -1848,6 +1924,11 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CNewsNewR) = return ("Neue Nachricht", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CNewsR tid ssh csh _ CNShowR) = return ("Kursnachricht" , Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CNewsR tid ssh csh cID CNEditR) = return ("Bearbeiten" , Just $ CNewsR tid ssh csh cID CNShowR)
|
||||
breadcrumb (CNewsR tid ssh csh cID CNDeleteR) = return ("Löschen" , Just $ CNewsR tid ssh csh cID CNShowR)
|
||||
|
||||
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)
|
||||
|
||||
@ -3135,12 +3216,18 @@ routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
|
||||
routeNormalizers =
|
||||
[ normalizeRender
|
||||
, ncSchool
|
||||
, ncAllocation
|
||||
, ncCourse
|
||||
, ncSheet
|
||||
, ncMaterial
|
||||
, ncTutorial
|
||||
, ncExam
|
||||
, verifySubmission
|
||||
, verifyCourseApplication
|
||||
, verifyCourseNews
|
||||
]
|
||||
where
|
||||
normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX)
|
||||
normalizeRender route = route <$ do
|
||||
YesodRequest{..} <- liftHandler getRequest
|
||||
let original = (W.pathInfo reqWaiRequest, reqGetParams)
|
||||
@ -3151,37 +3238,64 @@ routeNormalizers =
|
||||
| otherwise -> do
|
||||
$logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
|
||||
tell $ Any True
|
||||
|
||||
maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX))
|
||||
-> Route UniWorX -> WriterT Any DB (Route UniWorX)
|
||||
maybeOrig f route = maybeT (return route) $ f route
|
||||
hasChanged a b
|
||||
|
||||
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) ()
|
||||
caseChanged a b
|
||||
| ((/=) `on` original) a b = do
|
||||
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
ncSchool = maybeOrig $ \route -> do
|
||||
TermSchoolCourseListR tid ssh <- return route
|
||||
|
||||
ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
|
||||
let schoolShort :: SchoolShorthand
|
||||
schoolShort = unSchoolKey ssh
|
||||
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
||||
(hasChanged `on` unSchoolKey)ssh ssh'
|
||||
return $ TermSchoolCourseListR tid ssh'
|
||||
(caseChanged `on` unSchoolKey) ssh ssh'
|
||||
return ssh'
|
||||
ncAllocation = maybeOrig $ \route -> do
|
||||
AllocationR tid ssh ash _ <- return route
|
||||
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
caseChanged ash allocationShorthand
|
||||
return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
|
||||
ncCourse = maybeOrig $ \route -> do
|
||||
CourseR tid ssh csh subRoute <- return route
|
||||
Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
hasChanged csh courseShorthand
|
||||
(hasChanged `on` unSchoolKey) ssh courseSchool
|
||||
return $ CourseR tid courseSchool courseShorthand subRoute
|
||||
CourseR tid ssh csh _ <- return route
|
||||
Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
caseChanged csh courseShorthand
|
||||
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid ssh csh shn subRoute <- return route
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
hasChanged shn sheetName
|
||||
return $ CSheetR tid ssh csh sheetName subRoute
|
||||
CSheetR tid ssh csh shn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
|
||||
caseChanged shn sheetName
|
||||
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
|
||||
ncMaterial = maybeOrig $ \route -> do
|
||||
CMaterialR tid ssh csh mnm _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
|
||||
caseChanged mnm materialName
|
||||
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
|
||||
ncTutorial = maybeOrig $ \route -> do
|
||||
CTutorialR tid ssh csh tutn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
|
||||
caseChanged tutn tutorialName
|
||||
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
|
||||
ncExam = maybeOrig $ \route -> do
|
||||
CExamR tid ssh csh examn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
|
||||
caseChanged examn examName
|
||||
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
|
||||
verifySubmission = maybeOrig $ \route -> do
|
||||
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
||||
sId <- decrypt cID
|
||||
Submission{submissionSheet} <- lift . lift $ get404 sId
|
||||
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
|
||||
sId <- $cachedHereBinary cID $ decrypt cID
|
||||
Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
|
||||
Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
|
||||
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
@ -3193,6 +3307,14 @@ routeNormalizers =
|
||||
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseNews = maybeOrig $ \route -> do
|
||||
CNewsR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
|
||||
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
|
||||
|
||||
-- How to run database actions.
|
||||
@ -3202,7 +3324,9 @@ instance YesodPersist UniWorX where
|
||||
$logDebugS "YesodPersist" "runDB"
|
||||
runSqlPool action =<< appConnPool <$> getYesod
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
getDBRunner = do
|
||||
(DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
|
||||
return . (, cleanup) $ DBRunner (\act -> $logDebugS "YesodPersist" "runDBRunner" >> runDBRunner act)
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidEmail
|
||||
@ -3281,6 +3405,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
newUser = User
|
||||
{ userIdent = mk credsIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
|
||||
@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
|
||||
{ allocationUserAllocation = aId
|
||||
, allocationUserUser = uid
|
||||
, allocationUserTotalCourses = arfTotalCourses
|
||||
, allocationUserPriority = Nothing
|
||||
}
|
||||
[ AllocationUserTotalCourses =. arfTotalCourses
|
||||
]
|
||||
|
||||
@ -23,11 +23,16 @@ getAShowR tid ssh ash = do
|
||||
resultCourseApplication = _2 . _Just
|
||||
resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool
|
||||
resultHasTemplate = _3 . _Value
|
||||
resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
|
||||
resultIsRegistered = _4 . _Value
|
||||
|
||||
(Entity aId Allocation{..}, courses, registration) <- runDB $ do
|
||||
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
(Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
|
||||
alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
school <- getJust allocationSchool
|
||||
|
||||
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do
|
||||
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do
|
||||
E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
|
||||
E.&&. registration E.?. CourseParticipantUser E.==. E.val muid
|
||||
E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
|
||||
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
|
||||
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
|
||||
@ -36,11 +41,13 @@ getAShowR tid ssh ash = do
|
||||
E.orderBy [E.asc $ course E.^. CourseName]
|
||||
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
|
||||
return (course, courseApplication, hasTemplate)
|
||||
return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId)
|
||||
|
||||
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
|
||||
|
||||
return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration)
|
||||
isAnyLecturer <- hasWriteAccessTo CourseNewR
|
||||
|
||||
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
|
||||
@ -68,6 +75,7 @@ getAShowR tid ssh ash = do
|
||||
let Entity cid Course{..} = cEntry ^. resultCourse
|
||||
hasApplicationTemplate = cEntry ^. resultHasTemplate
|
||||
mApp = cEntry ^? resultCourseApplication
|
||||
isRegistered = cEntry ^. resultIsRegistered
|
||||
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
|
||||
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
||||
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
|
||||
@ -17,6 +17,7 @@ import Handler.Course.User as Handler.Course
|
||||
import Handler.Course.Users as Handler.Course
|
||||
import Handler.Course.Application as Handler.Course
|
||||
import Handler.ExamOffice.Course as Handler.Course
|
||||
import Handler.Course.News as Handler.Course
|
||||
|
||||
|
||||
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -28,3 +29,6 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
||||
getCNotesR = postCNotesR
|
||||
postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
|
||||
|
||||
postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler ()
|
||||
postCFavouriteR _ _ _ = error "not implemented"
|
||||
|
||||
9
src/Handler/Course/News.hs
Normal file
9
src/Handler/Course/News.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module Handler.Course.News
|
||||
( module Handler.Course.News
|
||||
) where
|
||||
|
||||
import Handler.Course.News.New as Handler.Course.News
|
||||
import Handler.Course.News.Edit as Handler.Course.News
|
||||
import Handler.Course.News.Download as Handler.Course.News
|
||||
import Handler.Course.News.Show as Handler.Course.News
|
||||
import Handler.Course.News.Delete as Handler.Course.News
|
||||
44
src/Handler/Course/News/Delete.hs
Normal file
44
src/Handler/Course/News/Delete.hs
Normal file
@ -0,0 +1,44 @@
|
||||
module Handler.Course.News.Delete
|
||||
( getCNDeleteR, postCNDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
|
||||
getCNDeleteR = postCNDeleteR
|
||||
postCNDeleteR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
|
||||
let
|
||||
drRecords :: Set (Key CourseNews)
|
||||
drRecords = Set.singleton nId
|
||||
|
||||
drGetInfo = return
|
||||
drUnjoin = id
|
||||
|
||||
drRenderRecord :: Entity CourseNews -> DB Widget
|
||||
drRenderRecord (Entity _ CourseNews{..})
|
||||
= return . fromMaybe (toWidget courseNewsContent) $ asum
|
||||
[ toWidget <$> courseNewsTitle
|
||||
, toWidget <$> courseNewsSummary
|
||||
]
|
||||
|
||||
drRecordConfirmString :: Entity CourseNews -> DB Text
|
||||
drRecordConfirmString _ = return ""
|
||||
|
||||
drCaption, drSuccessMessage :: SomeMessage UniWorX
|
||||
drCaption = SomeMessage MsgCourseNewsDeleteQuestion
|
||||
drSuccessMessage = SomeMessage MsgCourseNewsDeleted
|
||||
|
||||
drAbort, drSuccess :: SomeRoute UniWorX
|
||||
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
|
||||
|
||||
drDelete :: forall a. CourseNewsId -> DB a -> DB a
|
||||
drDelete _ = id
|
||||
|
||||
deleteR DeleteRoute{..}
|
||||
41
src/Handler/Course/News/Download.hs
Normal file
41
src/Handler/Course/News/Download.hs
Normal file
@ -0,0 +1,41 @@
|
||||
module Handler.Course.News.Download
|
||||
( getCNArchiveR
|
||||
, getCNFileR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent
|
||||
getCNArchiveR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
CourseNews{..} <- runDB $ get404 nId
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle)
|
||||
|
||||
let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $
|
||||
\(newsFile `E.InnerJoin` file) -> do
|
||||
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
return file
|
||||
|
||||
serveSomeFiles archiveName getFilesQuery
|
||||
|
||||
|
||||
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
|
||||
getCNFileR _ _ _ cID title = do
|
||||
nId <- decrypt cID
|
||||
|
||||
let
|
||||
fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do
|
||||
E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
E.&&. file E.^. FileTitle E.==. E.val title
|
||||
return file
|
||||
|
||||
serveOneFile $ fileQuery .| C.map entityVal
|
||||
54
src/Handler/Course/News/Edit.hs
Normal file
54
src/Handler/Course/News/Edit.hs
Normal file
@ -0,0 +1,54 @@
|
||||
module Handler.Course.News.Edit
|
||||
( getCNEditR, postCNEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Course.News.Form
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
getCNEditR, postCNEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
|
||||
getCNEditR = postCNEditR
|
||||
postCNEditR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
(courseNews@CourseNews{..}, fids) <- runDB $ do
|
||||
courseNews <- get404 nId
|
||||
cnfs <- selectList [CourseNewsFileNews ==. nId] []
|
||||
return ( courseNews
|
||||
, setOf (folded . _entityVal . _courseNewsFileFile) cnfs
|
||||
)
|
||||
|
||||
((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids
|
||||
|
||||
formResult newsRes $ \CourseNewsForm{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
replace nId CourseNews
|
||||
{ courseNewsCourse
|
||||
, courseNewsVisibleFrom = cnfVisibleFrom
|
||||
, courseNewsParticipantsOnly = cnfParticipantsOnly
|
||||
, courseNewsTitle = cnfTitle
|
||||
, courseNewsContent = cnfContent
|
||||
, courseNewsSummary = cnfSummary
|
||||
, courseNewsLastEdit = now
|
||||
}
|
||||
let
|
||||
insertFile (Left fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) []
|
||||
insertFile (Right f ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId)
|
||||
newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton
|
||||
deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ]
|
||||
addMessageI Success MsgCourseNewsEdited
|
||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
|
||||
siteLayoutMsg MsgMenuCourseNewsEdit $ do
|
||||
setTitleI MsgMenuCourseNewsEdit
|
||||
|
||||
wrapForm newsWgt' def
|
||||
{ formAction = Just . SomeRoute $ CNewsR tid ssh csh cID CNEditR
|
||||
, formEncoding = newsEnctype
|
||||
}
|
||||
71
src/Handler/Course/News/Form.hs
Normal file
71
src/Handler/Course/News/Form.hs
Normal file
@ -0,0 +1,71 @@
|
||||
module Handler.Course.News.Form
|
||||
( CourseNewsForm(..)
|
||||
, courseNewsForm
|
||||
, courseNewsToForm
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import Text.Blaze.Renderer.Text (renderMarkup)
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
data CourseNewsForm = CourseNewsForm
|
||||
{ cnfTitle :: Maybe Text
|
||||
, cnfSummary :: Maybe Html
|
||||
, cnfContent :: Html
|
||||
, cnfParticipantsOnly :: Bool
|
||||
, cnfVisibleFrom :: Maybe UTCTime
|
||||
, cnfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
|
||||
}
|
||||
|
||||
courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
|
||||
courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles
|
||||
cTime = ceilingQuarterHour now
|
||||
visibleFromTip
|
||||
| Just vFrom <- template >>= cnfVisibleFrom
|
||||
, vFrom <= now
|
||||
= MsgCourseNewsVisibleFromEditWarning
|
||||
| otherwise
|
||||
= MsgCourseNewsVisibleFromTip
|
||||
|
||||
cnfTitle' <- wopt
|
||||
(textField & cfStrip & guardField (not . null))
|
||||
(fslI MsgCourseNewsTitle)
|
||||
(cnfTitle <$> template)
|
||||
cnfSummary' <- wopt
|
||||
(htmlField & guardField (not . null . renderMarkup))
|
||||
(fslI MsgCourseNewsSummary & setTooltip MsgCourseNewsSummaryTip)
|
||||
(cnfSummary <$> template)
|
||||
cnfContent' <- wreq
|
||||
(htmlField & guardField (not . null . renderMarkup))
|
||||
(fslI MsgCourseNewsContent)
|
||||
(cnfContent <$> template)
|
||||
cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template)
|
||||
cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime))
|
||||
cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template)
|
||||
|
||||
return $ CourseNewsForm
|
||||
<$> cnfTitle'
|
||||
<*> cnfSummary'
|
||||
<*> cnfContent'
|
||||
<*> cnfParticipantsOnly'
|
||||
<*> cnfVisibleFrom'
|
||||
<*> cnfFiles'
|
||||
|
||||
courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm
|
||||
courseNewsToForm CourseNews{..} fs = CourseNewsForm
|
||||
{ cnfTitle = courseNewsTitle
|
||||
, cnfSummary = courseNewsSummary
|
||||
, cnfContent = courseNewsContent
|
||||
, cnfParticipantsOnly = courseNewsParticipantsOnly
|
||||
, cnfVisibleFrom = courseNewsVisibleFrom
|
||||
, cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs)
|
||||
}
|
||||
47
src/Handler/Course/News/New.hs
Normal file
47
src/Handler/Course/News/New.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module Handler.Course.News.New
|
||||
( getCNewsNewR, postCNewsNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Course.News.Form
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
getCNewsNewR, postCNewsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCNewsNewR = postCNewsNewR
|
||||
postCNewsNewR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
((newsRes, newsWgt'), newsEnctype) <- runFormPost $ courseNewsForm Nothing
|
||||
|
||||
formResult newsRes $ \CourseNewsForm{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
cID <- runDB $ do
|
||||
nId <- insert CourseNews
|
||||
{ courseNewsCourse = cid
|
||||
, courseNewsVisibleFrom = cnfVisibleFrom
|
||||
, courseNewsParticipantsOnly = cnfParticipantsOnly
|
||||
, courseNewsTitle = cnfTitle
|
||||
, courseNewsContent = cnfContent
|
||||
, courseNewsSummary = cnfSummary
|
||||
, courseNewsLastEdit = now
|
||||
}
|
||||
let
|
||||
insertFile (Left fId) = insert_ $ CourseNewsFile nId fId
|
||||
insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f
|
||||
forM_ cnfFiles $ \fSource ->
|
||||
runConduit $ transPipe lift fSource .| C.mapM_ insertFile
|
||||
encrypt nId :: DB CryptoUUIDCourseNews
|
||||
addMessageI Success MsgCourseNewsCreated
|
||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
|
||||
siteLayoutMsg MsgMenuCourseNewsNew $ do
|
||||
setTitleI MsgMenuCourseNewsNew
|
||||
|
||||
wrapForm newsWgt' def
|
||||
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CNewsNewR
|
||||
, formEncoding = newsEnctype
|
||||
}
|
||||
17
src/Handler/Course/News/Show.hs
Normal file
17
src/Handler/Course/News/Show.hs
Normal file
@ -0,0 +1,17 @@
|
||||
module Handler.Course.News.Show
|
||||
( getCNShowR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
getCNShowR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
|
||||
getCNShowR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
CourseNews{..} <- runDB $ get404 nId
|
||||
|
||||
siteLayout' (toWidget <$> courseNewsTitle) $ do
|
||||
setTitleI . prependCourseTitle tid ssh csh $ maybe (SomeMessage MsgCourseNews) SomeMessage courseNewsTitle
|
||||
|
||||
$(widgetFile "course-news")
|
||||
@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
, jParticipantAllocated :: Bool
|
||||
, jParticipantAllocated :: Maybe AllocationId
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing
|
||||
invitationInsertHook _ _ CourseParticipant{..} _ act = do
|
||||
res <- act
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
@ -141,6 +141,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
-> return $ FormSuccess Nothing
|
||||
| otherwise
|
||||
-> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||
|
||||
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
|
||||
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog
|
||||
|
||||
return $ CourseRegisterForm
|
||||
<$ secretRes
|
||||
@ -197,7 +200,7 @@ postCRegisterR tid ssh csh = do
|
||||
= return $ Just ()
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
|
||||
|
||||
deleteApplications = do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
@ -222,7 +225,7 @@ postCRegisterR tid ssh csh = do
|
||||
delete $ partId
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
when courseParticipantAllocated $ do
|
||||
when (is _Just courseParticipantAllocated) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
|
||||
|
||||
|
||||
@ -18,7 +18,7 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Register
|
||||
|
||||
import System.FilePath (addExtension)
|
||||
import System.FilePath (addExtension, pathSeparator)
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
@ -26,7 +26,7 @@ import qualified Data.Conduit.List as C
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do
|
||||
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) <- runDB . maybeT notFound $ do
|
||||
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
|
||||
<- lift . E.select . E.from $
|
||||
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
||||
@ -71,15 +71,31 @@ getCShowR tid ssh csh = do
|
||||
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
||||
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
||||
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication)
|
||||
news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
|
||||
cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
|
||||
guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
|
||||
let visible = cTime >= NTop courseNewsVisibleFrom
|
||||
files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do
|
||||
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle)
|
||||
let files = files'
|
||||
& over (mapped . _1) E.unValue
|
||||
& over (mapped . _2) E.unValue
|
||||
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
|
||||
mayEdit <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
||||
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
|
||||
return (cID, n, visible, files, lastEditText, mayEdit, mayDelete)
|
||||
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news)
|
||||
|
||||
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
|
||||
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
||||
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
|
||||
<$> pure allocationName
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
||||
<$> pure alloc
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
@ -236,6 +252,14 @@ getCShowR tid ssh csh = do
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
|
||||
|
||||
let visibleNews = any (view _3) news
|
||||
showNewsFiles fs = and
|
||||
[ not $ null fs
|
||||
, length fs <= 3
|
||||
, all (notElem pathSeparator . view _2) fs
|
||||
]
|
||||
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
|
||||
|
||||
siteLayout (toWgt $ courseName course) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
||||
$(widgetFile "course")
|
||||
|
||||
@ -118,31 +118,43 @@ postCUserR tid ssh csh uCId = do
|
||||
let regButton
|
||||
| is _Just mRegistration = BtnCourseDeregister
|
||||
| otherwise = BtnCourseRegister
|
||||
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
|
||||
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $
|
||||
if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration
|
||||
-> renderWForm FormStandard $ fmap (regButton, )
|
||||
<$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip)
|
||||
<*> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
|
||||
| otherwise
|
||||
-> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf)
|
||||
|
||||
let registrationButtonFrag :: Text
|
||||
registrationButtonFrag = "registration-button"
|
||||
regButtonWidget = wrapForm regButtonView FormSettings
|
||||
regButtonWidget = wrapForm' regButton regButtonView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
||||
, formEncoding = regButtonEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just registrationButtonFrag
|
||||
}
|
||||
formResult regButtonRes $ \case
|
||||
_
|
||||
| not mayRegister
|
||||
-> permissionDenied "User may not be registered"
|
||||
BtnCourseDeregister
|
||||
| Just (Entity pId _) <- mRegistration
|
||||
(BtnCourseDeregister, mbReason)
|
||||
| Just (Entity pId CourseParticipant{..}) <- mRegistration
|
||||
-> do
|
||||
runDB $ delete pId
|
||||
runDB $ do
|
||||
delete pId
|
||||
audit $ TransactionCourseParticipantDeleted cid courseParticipantUser
|
||||
|
||||
whenIsJust mbReason $ \reason -> do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
| otherwise
|
||||
-> invalidArgs ["User not registered"]
|
||||
BtnCourseRegister -> do
|
||||
(BtnCourseRegister, _) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let field
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
|
||||
@ -150,7 +162,7 @@ postCUserR tid ssh csh uCId = do
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB $ do
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field False
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field Nothing
|
||||
when (is _Just pId) $
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
return pId
|
||||
|
||||
@ -11,7 +11,6 @@ import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -126,18 +125,23 @@ instance Finite CourseUserAction
|
||||
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''CourseUserAction id
|
||||
|
||||
data CourseUserActionData = CourseUserSendMailData
|
||||
| CourseUserDeregisterData
|
||||
{ deregisterReason :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
makeCourseUserTable :: forall h acts.
|
||||
|
||||
makeCourseUserTable :: forall h act act'.
|
||||
( Functor h, ToSortable h
|
||||
, MonoFoldable acts
|
||||
, RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
|
||||
, Ord act, PathPiece act, RenderMessage UniWorX act
|
||||
)
|
||||
=> CourseId
|
||||
-> acts
|
||||
-> Map act (AForm Handler act')
|
||||
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (Element acts, Set UserId), Widget)
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (act', Set UserId), Widget)
|
||||
makeCourseUserTable cid acts restrict colChoices psValidator = do
|
||||
currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
-- -- psValidator has default sorting and filtering
|
||||
@ -209,7 +213,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
|
||||
, dbParamsFormAdditional
|
||||
= renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
|
||||
<$> multiActionA acts (fslI MsgAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
@ -218,17 +222,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
|
||||
dbtCsvDecode = Nothing
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
where
|
||||
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
|
||||
postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)
|
||||
postprocess inp = do
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
|
||||
courseUserDeregisterForm cid = wFormToAForm $ do
|
||||
allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
|
||||
if | allocated -> do
|
||||
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
|
||||
fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
|
||||
| otherwise -> pure . pure $ CourseUserDeregisterData Nothing
|
||||
|
||||
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCUsersR = postCUsersR
|
||||
postCUsersR tid ssh csh = do
|
||||
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
|
||||
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let colChoices = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
@ -241,27 +256,33 @@ postCUsersR tid ssh csh = do
|
||||
, colUserComment tid ssh csh
|
||||
]
|
||||
psValidator = def & defaultSortingByName
|
||||
acts = catMaybes
|
||||
[ Just CourseUserSendMail
|
||||
, guardOn mayRegister CourseUserDeregister
|
||||
acts = mconcat
|
||||
[ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
|
||||
, if
|
||||
| mayRegister
|
||||
-> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
|
||||
| otherwise
|
||||
-> mempty
|
||||
]
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
numParticipants <- count [CourseParticipantCourse ==. cid]
|
||||
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
|
||||
return (ent, numParticipants, table)
|
||||
formResult participantRes $ \case
|
||||
(CourseUserSendMail, selectedUsers) -> do
|
||||
(CourseUserSendMailData, selectedUsers) -> do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(CourseUserDeregister,selectedUsers) -> do
|
||||
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
|
||||
nrDel <- deleteWhereCount
|
||||
[ CourseParticipantCourse ==. cid
|
||||
, CourseParticipantUser ==. uid
|
||||
]
|
||||
unless (nrDel == 0) $
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
return $ Sum nrDel
|
||||
(CourseUserDeregisterData{..}, selectedUsers) -> do
|
||||
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
|
||||
now <- liftIO getCurrentTime
|
||||
Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
|
||||
lift $ delete reg
|
||||
lift . audit $ TransactionCourseParticipantDeleted cid uid
|
||||
case deregisterReason of
|
||||
Just reason
|
||||
| is _Just courseParticipantAllocated ->
|
||||
lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
|
||||
_other -> return ()
|
||||
return 1
|
||||
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
|
||||
|
||||
@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $ \cpField -> do
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
|
||||
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
|
||||
|
||||
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
|
||||
|
||||
@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
}
|
||||
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
|
||||
insert_ ExamRegistration
|
||||
|
||||
@ -61,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
|
||||
flip (renderAForm FormStandard) html $ MaterialForm
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template)
|
||||
<*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions)
|
||||
<*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
|
||||
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
|
||||
(mfType <$> template)
|
||||
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
|
||||
|
||||
@ -29,16 +29,17 @@ import Jobs
|
||||
|
||||
|
||||
data SettingsForm = SettingsForm
|
||||
{ stgDisplayName :: UserDisplayName
|
||||
, stgDisplayEmail :: UserEmail
|
||||
, stgMaxFavourties :: Int
|
||||
, stgTheme :: Theme
|
||||
, stgDateTime :: DateTimeFormat
|
||||
, stgDate :: DateTimeFormat
|
||||
, stgTime :: DateTimeFormat
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgSchools :: Set SchoolId
|
||||
{ stgDisplayName :: UserDisplayName
|
||||
, stgDisplayEmail :: UserEmail
|
||||
, stgMaxFavourites :: Int
|
||||
, stgMaxFavouriteTerms :: Int
|
||||
, stgTheme :: Theme
|
||||
, stgDateTime :: DateTimeFormat
|
||||
, stgDate :: DateTimeFormat
|
||||
, stgTime :: DateTimeFormat
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgSchools :: Set SchoolId
|
||||
, stgNotificationSettings :: NotificationSettings
|
||||
}
|
||||
makeLenses_ ''SettingsForm
|
||||
@ -49,6 +50,7 @@ data NotificationTriggerKind
|
||||
| NTKExamParticipant
|
||||
| NTKCorrector
|
||||
| NTKAllocationStaff
|
||||
| NTKAllocationParticipant
|
||||
| NTKFunctionary SchoolFunction
|
||||
deriving (Eq, Ord, Generic, Typeable)
|
||||
deriveFinite ''NotificationTriggerKind
|
||||
@ -60,6 +62,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where
|
||||
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
|
||||
NTKCorrector -> mr MsgNotificationTriggerKindCorrector
|
||||
NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
|
||||
NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
|
||||
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
|
||||
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
|
||||
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
|
||||
@ -75,8 +78,10 @@ makeSettingForm template html = do
|
||||
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
|
||||
<*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
|
||||
<* aformSection MsgFormCosmetics
|
||||
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
|
||||
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
|
||||
<*> areq (natFieldI $ MsgNatField "Favoriten")
|
||||
(fslpI MsgFavourites "Anzahl Favoriten" & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
|
||||
<*> areq (natFieldI $ MsgNatField "Favoriten-Semester")
|
||||
(fslpI MsgFavouriteSemesters "Anzahl Semester") (stgMaxFavouriteTerms <$> template)
|
||||
<*> areq (selectField . return $ mkOptionList themeList)
|
||||
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
|
||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
|
||||
@ -185,6 +190,7 @@ notificationForm template = wFormToAForm $ do
|
||||
NTAllocationRegister -> Just NTKAll
|
||||
NTAllocationOutdatedRatings -> Just NTKAllocationStaff
|
||||
NTAllocationUnratedApplications -> Just NTKAllocationStaff
|
||||
NTAllocationResults -> Just NTKAllocationParticipant
|
||||
NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice
|
||||
NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice
|
||||
-- _other -> Nothing
|
||||
@ -232,43 +238,38 @@ postProfileR = do
|
||||
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
|
||||
return $ school E.^. SchoolId
|
||||
let settingsTemplate = Just SettingsForm
|
||||
{ stgDisplayName = userDisplayName
|
||||
, stgDisplayEmail = userDisplayEmail
|
||||
, stgMaxFavourties = userMaxFavourites
|
||||
, stgTheme = userTheme
|
||||
, stgDateTime = userDateTimeFormat
|
||||
, stgDate = userDateFormat
|
||||
, stgTime = userTimeFormat
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgSchools = userSchools
|
||||
{ stgDisplayName = userDisplayName
|
||||
, stgDisplayEmail = userDisplayEmail
|
||||
, stgMaxFavourites = userMaxFavourites
|
||||
, stgMaxFavouriteTerms = userMaxFavouriteTerms
|
||||
, stgTheme = userTheme
|
||||
, stgDateTime = userDateTimeFormat
|
||||
, stgDate = userDateFormat
|
||||
, stgTime = userTimeFormat
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgSchools = userSchools
|
||||
, stgNotificationSettings = userNotificationSettings
|
||||
, stgWarningDays = userWarningDays
|
||||
, stgWarningDays = userWarningDays
|
||||
}
|
||||
((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
||||
|
||||
formResult res $ \SettingsForm{..} -> do
|
||||
runDBJobs $ do
|
||||
update uid $
|
||||
[ UserDisplayName =. stgDisplayName
|
||||
, UserMaxFavourites =. stgMaxFavourties
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserWarningDays =. stgWarningDays
|
||||
[ UserDisplayName =. stgDisplayName
|
||||
, UserMaxFavourites =. stgMaxFavourites
|
||||
, UserMaxFavouriteTerms =. stgMaxFavouriteTerms
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserWarningDays =. stgWarningDays
|
||||
, UserNotificationSettings =. stgNotificationSettings
|
||||
] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
|
||||
when (stgDisplayEmail /= userDisplayEmail) $ do
|
||||
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
|
||||
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
|
||||
when (stgMaxFavourties < userMaxFavourites) $ do
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
|
||||
[ Desc CourseFavouriteTime
|
||||
, OffsetBy stgMaxFavourties
|
||||
]
|
||||
mapM_ delete oldFavs
|
||||
let
|
||||
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
|
||||
forM_ symDiff $ \ssh -> if
|
||||
|
||||
@ -14,6 +14,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
@ -51,7 +52,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
table <- makeCourseUserTable cid universeF isInTut colChoices psValidator
|
||||
table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator
|
||||
return (tut, table)
|
||||
|
||||
formResult participantRes $ \case
|
||||
|
||||
@ -65,6 +65,7 @@ postAdminUserAddR = do
|
||||
newUser@User{..} = User
|
||||
{ userIdent = aufIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
|
||||
186
src/Handler/Utils/Allocation.hs
Normal file
186
src/Handler/Utils/Allocation.hs
Normal file
@ -0,0 +1,186 @@
|
||||
module Handler.Utils.Allocation
|
||||
( allocationDone
|
||||
, ordinalPriorities
|
||||
, sinkAllocationPriorities
|
||||
, computeAllocation
|
||||
, storeAllocationFingerprint
|
||||
, doAllocation
|
||||
, ppMatchingLog, storeMatchingLog
|
||||
, storeAllocationResult
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Control.Monad.State.Class as State (get, modify')
|
||||
|
||||
import Data.List (genericLength, elemIndex)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Vector.Lens (vector)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Random (mkStdGen)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
import Data.Conduit.Lift (evalStateC)
|
||||
|
||||
import Data.Generics.Product.Param
|
||||
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.ByteArray as BA (convert)
|
||||
|
||||
|
||||
allocationDone :: AllocationId -> DB (Maybe UTCTime)
|
||||
allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
|
||||
return . E.max_ $ participant E.^. CourseParticipantRegistration
|
||||
|
||||
|
||||
ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
|
||||
ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ)
|
||||
|
||||
sinkAllocationPriorities :: AllocationId
|
||||
-> ConduitT (Map UserMatriculation AllocationPriority) Void DB ()
|
||||
sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
|
||||
E.update $ \allocationUser -> do
|
||||
E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ]
|
||||
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId
|
||||
E.where_ . E.exists . E.from $ \user ->
|
||||
E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
|
||||
E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr)
|
||||
|
||||
|
||||
computeAllocation :: AllocationId
|
||||
-> DB (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
computeAllocation allocId = do
|
||||
users' <- selectList [ AllocationUserAllocation ==. allocId ] []
|
||||
let users'' = users'
|
||||
& mapMaybe ( runMaybeT $ (,) <$> lift (allocationUserUser . entityVal)
|
||||
<*> ( (,) <$> lift (allocationUserTotalCourses . entityVal)
|
||||
<*> MaybeT (allocationUserPriority . entityVal)
|
||||
)
|
||||
)
|
||||
& Map.fromList
|
||||
& Map.filter ((> 0) . view _1)
|
||||
cloneCounts = Map.map (view _1) users''
|
||||
allocationPrio = view _2 . (Map.!) users''
|
||||
|
||||
courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
|
||||
|
||||
let participants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
|
||||
return E.countRows
|
||||
|
||||
return ( allocationCourse
|
||||
, E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity)
|
||||
, allocationCourse E.^. AllocationCourseMinCapacity E.-. participants
|
||||
)
|
||||
let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
|
||||
|
||||
applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
|
||||
let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
|
||||
preferences = Map.fromList $ do
|
||||
Entity _ CourseApplication{..} <- applications''
|
||||
return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
|
||||
|
||||
gradeScale <- getsYesod $ view _appAllocationGradeScale
|
||||
gradeOrdinalPlaces <- getsYesod $ view _appAllocationGradeOrdinalPlaces
|
||||
let centralNudge user cloneIndex grade = case allocationPrio user of
|
||||
AllocationPriorityNumeric{..}
|
||||
-> let allocationPriorities' = under vector (sortOn Down) allocationPriorities
|
||||
minPrio | Vector.null allocationPriorities' = 0
|
||||
| otherwise = Vector.last allocationPriorities'
|
||||
in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex
|
||||
AllocationPriorityOrdinal{..}
|
||||
| gradeOrdinalPlaces > 0
|
||||
-> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal
|
||||
in AllocationPriorityComparisonOrdinal (Down cloneIndex) $ withNumericGrade allocationOrdinal'
|
||||
AllocationPriorityOrdinal{..}
|
||||
-> AllocationPriorityComparisonOrdinal (Down cloneIndex) $ fromIntegral allocationOrdinal
|
||||
where
|
||||
withNumericGrade :: Rational -> Rational
|
||||
withNumericGrade
|
||||
| Just grade' <- grade
|
||||
= let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
||||
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
||||
in (+) numericGrade
|
||||
| otherwise
|
||||
= id
|
||||
|
||||
let
|
||||
fingerprint :: AllocationFingerprint
|
||||
fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
|
||||
|
||||
g = mkStdGen $ hash (BA.convert fingerprint :: ByteString)
|
||||
|
||||
let
|
||||
doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
|
||||
where
|
||||
capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities
|
||||
preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences
|
||||
|
||||
allocationLoop cs
|
||||
| not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
|
||||
| otherwise = (allocs, mLog)
|
||||
where
|
||||
(allocs, mLog) = doAllocationWithout cs
|
||||
belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
|
||||
guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
|
||||
|
||||
return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty
|
||||
|
||||
|
||||
storeAllocationFingerprint :: AllocationId
|
||||
-> AllocationFingerprint
|
||||
-> DB ()
|
||||
storeAllocationFingerprint allocId fp = update allocId [ AllocationFingerprint =. Just fp ]
|
||||
|
||||
doAllocation :: AllocationId
|
||||
-> Set (UserId, CourseId)
|
||||
-> DB ()
|
||||
doAllocation allocId regs = do
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ regs $ \(uid, cid) -> do
|
||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void . insertUnique $ CourseParticipant cid uid now mField (Just allocId)
|
||||
|
||||
ppMatchingLog :: ( MonoFoldable mono
|
||||
, Element mono ~ MatchingLog UserId CourseId Natural
|
||||
)
|
||||
=> mono -> Text
|
||||
ppMatchingLog = unlines . map (tshow . pretty) . otoList
|
||||
where
|
||||
pretty = over (param @1) fromSqlKey
|
||||
. over (param @2) fromSqlKey
|
||||
|
||||
storeMatchingLog :: ( MonoFoldable mono
|
||||
, Element mono ~ MatchingLog UserId CourseId Natural
|
||||
)
|
||||
=> AllocationId -> mono -> DB ()
|
||||
storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do
|
||||
now <- liftIO getCurrentTime
|
||||
fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now
|
||||
update allocationId [ AllocationMatchingLog =. Just fId ]
|
||||
|
||||
|
||||
storeAllocationResult :: AllocationId
|
||||
-> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
-> DB ()
|
||||
storeAllocationResult allocId (allocFp, allocMatchings, allocLog) = do
|
||||
storeAllocationFingerprint allocId allocFp
|
||||
doAllocation allocId allocMatchings
|
||||
storeMatchingLog allocId allocLog
|
||||
@ -1,7 +1,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Csv
|
||||
( decodeCsv
|
||||
( decodeCsv, decodeCsvPositional
|
||||
, encodeCsv
|
||||
, encodeDefaultOrderedCsv
|
||||
, respondCsv, respondCsvDB
|
||||
@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
|
||||
import Control.Monad.Except (ExceptT)
|
||||
|
||||
|
||||
decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
|
||||
decodeCsv = transPipe throwExceptT $ do
|
||||
decodeCsv = decodeCsv' fromNamedCsv
|
||||
|
||||
decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m ()
|
||||
decodeCsvPositional hdr = decodeCsv' (`fromCsv` hdr)
|
||||
|
||||
decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m ()
|
||||
decodeCsv' fromCsv' = transPipe throwExceptT $ do
|
||||
testBuffer <- accumTestBuffer LBS.empty
|
||||
mapM_ leftover $ LBS.toChunks testBuffer
|
||||
|
||||
@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do
|
||||
& guessDelimiter testBuffer
|
||||
$logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|]
|
||||
|
||||
fromNamedCsv decodeOptions
|
||||
fromCsv' decodeOptions
|
||||
where
|
||||
testBufferSize = 4096
|
||||
accumTestBuffer acc
|
||||
|
||||
@ -53,14 +53,17 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
|
||||
where
|
||||
aform = (,)
|
||||
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
|
||||
<*> disambiguateButtons (combinedButtonFieldF "")
|
||||
<*> pure BtnDelete
|
||||
confirmField
|
||||
| multiple = convertField unTextarea Textarea textareaField
|
||||
| otherwise = textField
|
||||
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
|
||||
|
||||
confirmFormReduced :: Monad m => AForm m Bool
|
||||
confirmFormReduced = pure True
|
||||
|
||||
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
|
||||
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
|
||||
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString
|
||||
where
|
||||
addDeleteTargets :: Form a -> Form a
|
||||
addDeleteTargets form csrf = do
|
||||
@ -99,10 +102,10 @@ getDeleteR DeleteRoute{..} = do
|
||||
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
|
||||
|
||||
targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
|
||||
let deleteForm = wrapForm deleteFormWdgt def
|
||||
let deleteForm = wrapForm' BtnDelete deleteFormWdgt def
|
||||
{ formAction = Just $ SomeRoute targetRoute
|
||||
, formEncoding = deleteFormEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
, formSubmit = FormSubmit
|
||||
}
|
||||
|
||||
sendResponse =<<
|
||||
|
||||
@ -747,10 +747,11 @@ multiFileField permittedFiles' = Field{..}
|
||||
| otherwise = True
|
||||
return FileUploadInfo{..}
|
||||
autoUnzipInfo = [whamlet| _{MsgAutoUnzipInfo} |]
|
||||
fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
|
||||
fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
|
||||
E.orderBy [E.asc $ file E.^. FileTitle]
|
||||
return (file E.^. FileId, file E.^. FileTitle)
|
||||
let fileInfos = sortOn fuiTitle fileInfos'
|
||||
$(widgetFile "widgets/multiFileField")
|
||||
unpackZips :: Text
|
||||
unpackZips = "unpack-zip"
|
||||
|
||||
@ -961,7 +961,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
||||
|
||||
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
|
||||
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
|
||||
firstRow :: Int64
|
||||
firstRow
|
||||
| PagesizeLimit l <- psLimit
|
||||
@ -974,7 +974,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
| otherwise
|
||||
= id
|
||||
|
||||
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
|
||||
(currentKeys, rows) <- fmap unzip . mapMaybeM' dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
|
||||
|
||||
|
||||
formResult csvMode $ \case
|
||||
|
||||
@ -15,6 +15,7 @@ import Data.Time.Zones
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Allocation (allocationDone)
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
@ -336,5 +337,15 @@ determineCrontab = execWriterT $ do
|
||||
}
|
||||
_other
|
||||
-> return ()
|
||||
doneSince <- lift $ allocationDone nAllocation
|
||||
whenIsJust doneSince $ \doneSince' ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
|
||||
, cronRepeat = CronRepeatNever
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = Left appNotificationExpiration
|
||||
}
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs
|
||||
|
||||
@ -198,6 +198,18 @@ determineNotificationCandidates NotificationExamOfficeExamResultsChanged{..} =
|
||||
E.where_ $ examResult E.^. ExamResultId `E.in_` E.valList (Set.toList nExamResults)
|
||||
E.where_ $ examOfficeExamResultAuth (user E.^. UserId) examResult
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationResults{..} =
|
||||
E.select . E.from $ \user -> do
|
||||
let isStudent = E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation)
|
||||
E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
|
||||
isLecturer = E.exists . E.from $ \(lecturer `E.InnerJoin` allocationCourse) ->
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
E.where_ $ isStudent E.||. isLecturer
|
||||
|
||||
return user
|
||||
|
||||
|
||||
classifyNotification :: Notification -> DB NotificationTrigger
|
||||
@ -224,3 +236,4 @@ classifyNotification NotificationAllocationOutdatedRatings{} = return NTAll
|
||||
classifyNotification NotificationAllocationUnratedApplications{} = return NTAllocationUnratedApplications
|
||||
classifyNotification NotificationExamOfficeExamResults{} = return NTExamOfficeExamResults
|
||||
classifyNotification NotificationExamOfficeExamResultsChanged{} = return NTExamOfficeExamResultsChanged
|
||||
classifyNotification NotificationAllocationResults{} = return NTAllocationResults
|
||||
|
||||
@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.Allocation
|
||||
, dispatchNotificationAllocationAllocation
|
||||
, dispatchNotificationAllocationUnratedApplications
|
||||
, dispatchNotificationAllocationOutdatedRatings
|
||||
, dispatchNotificationAllocationResults
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -157,3 +158,43 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationOutdatedRatings.hamlet")
|
||||
|
||||
dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do
|
||||
(Allocation{..}, lecturerResults, participantResults) <- liftHandler . runDB $ do
|
||||
allocation <- getJust nAllocation
|
||||
|
||||
lecturerResults' <- E.select . E.from $ \(lecturer `E.InnerJoin` course) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient
|
||||
E.&&. E.exists (E.from $ \allocationCourse ->
|
||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
)
|
||||
let participantCount = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
||||
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
|
||||
return (course, participantCount)
|
||||
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value partCount) -> SomeMessage $ MsgAllocationResultLecturer courseShorthand partCount
|
||||
|
||||
doParticipantResults <- E.selectExists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation)
|
||||
E.&&. application E.^. CourseApplicationUser E.==. E.val jRecipient
|
||||
participantResults' <- E.select . E.from $ \(participant `E.InnerJoin` course) -> do
|
||||
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
||||
E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient
|
||||
return course
|
||||
let participantResults = case participantResults' of
|
||||
[] | doParticipantResults -> Just []
|
||||
| otherwise -> Nothing
|
||||
cs -> Just $ map (courseShorthand . entityVal) cs
|
||||
|
||||
return (allocation, lecturerResults, participantResults)
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationResults allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationResults.hamlet")
|
||||
|
||||
@ -87,6 +87,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationAllocationOutdatedRatings { nAllocation :: AllocationId }
|
||||
| NotificationExamOfficeExamResults { nExam :: ExamId }
|
||||
| NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
|
||||
| NotificationAllocationResults { nAllocation :: AllocationId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Hashable Job
|
||||
|
||||
@ -550,6 +550,24 @@ customMigrations = Map.fromListWith (>>)
|
||||
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
||||
, whenM (tableExists "course_favourite") $
|
||||
[executeQQ|
|
||||
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
||||
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|24.0.0|] [version|25.0.0|]
|
||||
, whenM (tableExists "course_participant") $ do
|
||||
queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|]
|
||||
case queryRes of
|
||||
[Single False] ->
|
||||
[executeQQ|
|
||||
ALTER TABLE "course_participant" DROP COLUMN "allocated";
|
||||
ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint;
|
||||
|]
|
||||
_other -> error "Cannot reconstruct course_participant.allocated"
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -13,3 +13,4 @@ import Model.Types.Sheet as Types
|
||||
import Model.Types.Submission as Types
|
||||
import Model.Types.Misc as Types
|
||||
import Model.Types.School as Types
|
||||
import Model.Types.Allocation as Types
|
||||
|
||||
52
src/Model/Types/Allocation.hs
Normal file
52
src/Model/Types/Allocation.hs
Normal file
@ -0,0 +1,52 @@
|
||||
module Model.Types.Allocation
|
||||
( AllocationPriority(..)
|
||||
, AllocationPriorityComparison(..)
|
||||
, AllocationFingerprint
|
||||
, module Utils.Allocation
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Utils.Allocation (MatchingLog(..))
|
||||
import Model.Types.Common
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Crypto.Hash (Digest, SHAKE128)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
|
||||
data AllocationPriority
|
||||
= AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
|
||||
| AllocationPriorityOrdinal { allocationOrdinal :: Natural }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 2
|
||||
, allNullaryToStringTag = False
|
||||
, sumEncoding = TaggedObject "mode" "value"
|
||||
, unwrapUnaryRecords = False
|
||||
, tagSingleConstructors = True
|
||||
} ''AllocationPriority
|
||||
derivePersistFieldJSON ''AllocationPriority
|
||||
|
||||
instance Binary AllocationPriority
|
||||
|
||||
instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
|
||||
parseRecord v = parseNumeric
|
||||
where
|
||||
parseNumeric
|
||||
| Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
|
||||
| otherwise = mzero
|
||||
|
||||
|
||||
data AllocationPriorityComparison
|
||||
= AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational }
|
||||
| AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
type AllocationFingerprint = Digest (SHAKE128 128)
|
||||
@ -218,6 +218,8 @@ instance PersistField ExamGrade where
|
||||
instance PersistFieldSql ExamGrade where
|
||||
sqlType _ = SqlNumeric 2 1
|
||||
|
||||
instance Binary ExamGrade
|
||||
|
||||
|
||||
newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade }
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
@ -40,6 +40,7 @@ data NotificationTrigger
|
||||
| NTAllocationRegister
|
||||
| NTAllocationOutdatedRatings
|
||||
| NTAllocationUnratedApplications
|
||||
| NTAllocationResults
|
||||
| NTExamOfficeExamResults
|
||||
| NTExamOfficeExamResultsChanged
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
@ -131,3 +131,17 @@ instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where
|
||||
_partContent .= Csv.encodeByNameWith (encOpts ^. _CsvEncodeOptions) csvRenderedHeader csvRenderedData
|
||||
instance YesodMail site => ToMailPart site CsvRendered where
|
||||
toMailPart = toMailPart . (, def :: CsvOptions)
|
||||
|
||||
|
||||
data FavouriteReason
|
||||
= FavouriteVisited
|
||||
| FavouriteParticipant
|
||||
| FavouriteManual
|
||||
| FavouriteCurrent
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe FavouriteReason
|
||||
instance Finite FavouriteReason
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''FavouriteReason
|
||||
derivePersistFieldJSON ''FavouriteReason
|
||||
|
||||
@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
import Data.Time (NominalDiffTime, nominalDay)
|
||||
|
||||
import Data.Scientific (toBoundedInteger)
|
||||
import Data.Scientific (Scientific, toBoundedInteger)
|
||||
import Data.Word (Word16)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -130,6 +130,9 @@ data AppSettings = AppSettings
|
||||
|
||||
, appTransactionLogIPRetentionTime :: NominalDiffTime
|
||||
|
||||
, appAllocationGradeScale :: Rational
|
||||
, appAllocationGradeOrdinalPlaces :: Natural
|
||||
|
||||
, appReloadTemplates :: Bool
|
||||
-- ^ Use the reload version of templates
|
||||
, appMutableStatic :: Bool
|
||||
@ -168,7 +171,7 @@ instance NFData LogDestination
|
||||
|
||||
data UserDefaultConf = UserDefaultConf
|
||||
{ userDefaultTheme :: Theme
|
||||
, userDefaultMaxFavourites :: Int
|
||||
, userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
|
||||
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
|
||||
, userDefaultDownloadFiles :: Bool
|
||||
, userDefaultWarningDays :: NominalDiffTime
|
||||
@ -426,6 +429,9 @@ instance FromJSON AppSettings where
|
||||
|
||||
appTransactionLogIPRetentionTime <- o .: "ip-retention-time"
|
||||
|
||||
appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific)
|
||||
appAllocationGradeOrdinalPlaces <- o .: "allocation-grade-ordinal-places"
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
|
||||
16
src/Utils.hs
16
src/Utils.hs
@ -51,7 +51,9 @@ import Control.Arrow as Utils ((>>>))
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
|
||||
import Control.Monad.Trans.Writer.Lazy (execWriterT, tell)
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Morph (hoist)
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Instances ()
|
||||
@ -529,6 +531,20 @@ maybeThrow exc = maybe (throwM exc) return
|
||||
maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a
|
||||
maybeThrowM excM = maybe (throwM =<< excM) return
|
||||
|
||||
mapMaybeM :: ( Monad m
|
||||
, MonoFoldable (f a)
|
||||
, MonoPointed (f b)
|
||||
, Monoid (f b)
|
||||
) => (Element (f a) -> MaybeT m (Element (f b))) -> f a -> m (f b)
|
||||
mapMaybeM f = execWriterT . mapM_ (void . runMaybeT . (lift . tell . opoint <=< hoist lift . f))
|
||||
|
||||
forMaybeM :: ( Monad m
|
||||
, MonoFoldable (f a)
|
||||
, MonoPointed (f b)
|
||||
, Monoid (f b)
|
||||
) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
|
||||
forMaybeM = flip mapMaybeM
|
||||
|
||||
------------
|
||||
-- Either --
|
||||
------------
|
||||
|
||||
281
src/Utils/Allocation.hs
Normal file
281
src/Utils/Allocation.hs
Normal file
@ -0,0 +1,281 @@
|
||||
module Utils.Allocation
|
||||
( computeMatching
|
||||
, MatchingLog(..)
|
||||
, computeMatchingLog
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding (StateT, st, get)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Data.Array.ST (STArray)
|
||||
import qualified Data.Array.MArray as MArr
|
||||
|
||||
import System.Random (RandomGen)
|
||||
import Control.Monad.Random.Class (getRandom)
|
||||
import Control.Monad.Trans.Random.Strict (evalRandT, RandT)
|
||||
import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
|
||||
import Control.Monad.Writer (tell)
|
||||
|
||||
import Control.Monad.ST
|
||||
|
||||
import Data.List ((!!), elemIndex)
|
||||
|
||||
|
||||
type CourseIndex = Int
|
||||
type StudentIndex = Int
|
||||
type CloneIndex = Int
|
||||
|
||||
data MatchingLog student course cloneIndex
|
||||
= MatchingConsider
|
||||
{ mlStudent :: student, mlClone :: cloneIndex }
|
||||
| MatchingApply
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
| MatchingNoApplyCloneInstability
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
| MatchingLostSpot
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex)
|
||||
|
||||
computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
|
||||
( RandomGen randomGen
|
||||
, Ord student, Ord course
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student cloneCount -- ^ requested number of placements per student
|
||||
-> Map course (Maybe capacity) -- ^ capacity of courses
|
||||
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
|
||||
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
|
||||
-> Set (student, course) -- ^ Stable matching
|
||||
computeMatching g cloneCounts capacities preferences centralNudge
|
||||
= view _1 . runWriter $ computeMatchingLog g cloneCounts capacities preferences centralNudge
|
||||
|
||||
computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
|
||||
( RandomGen randomGen
|
||||
, Ord student, Ord course
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student cloneCount -- ^ requested number of placements per student
|
||||
-> Map course (Maybe capacity) -- ^ capacity of courses
|
||||
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
|
||||
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
|
||||
-> Writer (Seq (MatchingLog student course cloneIndex)) (Set (student, course)) -- ^ Stable matching
|
||||
computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ runST computeMatching'
|
||||
where
|
||||
computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex))
|
||||
computeMatching' = runWriterT . flip evalRandT g $ do
|
||||
stb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) ((student, CloneIndex) -> UUID)
|
||||
cstb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) courses) :: RandT randomGen (WriterT _ (ST s)) (course -> UUID)
|
||||
|
||||
courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s CourseIndex (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex))))
|
||||
|
||||
stPrefs <- lift . lift $ MArr.newArray studentBounds [] :: RandT randomGen (WriterT _ (ST s)) (STArray s (StudentIndex, CloneIndex) [course])
|
||||
forM_ clonedStudents $ \(st, cn) ->
|
||||
lift . lift . MArr.writeArray stPrefs (st ^. contStudents, cn) $ studentPrefs cstb (st, cn)
|
||||
|
||||
let
|
||||
propose :: StateT (Set (student, CloneIndex)) (WriterT _ (ST s)) ()
|
||||
propose = (=<< get) . mapM_ $ \(st, cn) -> do
|
||||
lift . tell . pure . MatchingConsider st $ fromIntegral cn
|
||||
let markDone = modify' $ Set.delete (st, cn)
|
||||
|
||||
options <- lift . lift $ MArr.readArray stPrefs (st ^. contStudents, cn)
|
||||
case options of
|
||||
[] -> markDone
|
||||
c : cs -> do
|
||||
lift . lift $ MArr.writeArray stPrefs (st ^. contStudents, cn) cs
|
||||
cState <- lift . lift $ MArr.readArray courses' (c ^. contCourses)
|
||||
case cState of
|
||||
Left pSet
|
||||
| none (\(st', _) -> st == st') pSet -> do
|
||||
lift . tell . pure $ MatchingApply st (fromIntegral cn) c
|
||||
lift . lift . MArr.writeArray courses' (c ^. contCourses) $!! Left (Set.insert (st, cn) pSet)
|
||||
markDone
|
||||
Right spots
|
||||
| none (\(st', _) -> st == st') spots -> do
|
||||
courseMatchings <- lift . lift $ MArr.getAssocs courses'
|
||||
let
|
||||
matchingCourse s cn' = listToMaybe $ do
|
||||
(review contCourses -> course, students) <- courseMatchings
|
||||
student <- case students of
|
||||
Left pSet -> toList pSet
|
||||
Right spots' -> toList spots'
|
||||
guard $ (s, cn') == student
|
||||
return course
|
||||
|
||||
let capacity = maybe (error "course without capacity treated as one") fromIntegral . fromMaybe (error "course not found in capacities") $ capacities Map.!? c
|
||||
(worseSpots, betterSpots) = Seq.spanr isWorseSpot spots
|
||||
isWorseSpot existing = case (comparing $ fromMaybe (error "(st, c) not in preferences") . courseRating c &&& stb) existing (st, cn) of
|
||||
EQ -> error "Two student-clones compared equal in the face of stb"
|
||||
GT -> False
|
||||
LT -> True
|
||||
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
|
||||
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
||||
isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
|
||||
c' <- matchingCourse st cn'
|
||||
rMe <- courseRating c' (st, cn')
|
||||
rOther <- courseRating c' (stO, cnO)
|
||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
|
||||
|
||||
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
||||
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
||||
| Seq.length betterSpots >= capacity
|
||||
-> return ()
|
||||
| otherwise
|
||||
-> do
|
||||
lift . tell . pure $ MatchingApply st (fromIntegral cn) c
|
||||
lift . lift . MArr.writeArray courses' (c ^. contCourses) $ Right newSpots
|
||||
forM_ lostSpots $ \(st', cn') -> do
|
||||
lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c
|
||||
modify' $ Set.insert (st', cn')
|
||||
markDone
|
||||
_other -> return ()
|
||||
|
||||
proposeLoop = do
|
||||
propose
|
||||
done <- gets Set.null
|
||||
unless done
|
||||
proposeLoop
|
||||
|
||||
lift $ evalStateT proposeLoop clonedStudents
|
||||
|
||||
|
||||
-- let
|
||||
-- pairwiseExchange :: ST s ()
|
||||
-- pairwiseExchange = do
|
||||
-- let possiblePairs = do
|
||||
-- (s:ss) <- tails . sortOn stb $ toList clonedStudents
|
||||
-- s' <- ss
|
||||
-- return (s, s')
|
||||
-- matchingCourse (s, c) = do
|
||||
-- courseMatchings <- MArr.getAssocs courses'
|
||||
-- return . listToMaybe $ do
|
||||
-- (course, students) <- courseMatchings
|
||||
-- student <- case students of
|
||||
-- Left pSet -> toList pSet
|
||||
-- Right spots -> toList spots
|
||||
-- guard $ (s, c) == student
|
||||
-- return course
|
||||
-- forM_ possiblePairs $ \((a, cna), (b, cnb)) -> void . runMaybeT $ do
|
||||
-- ca <- MaybeT $ matchingCourse (a, cna)
|
||||
-- cb <- MaybeT $ matchingCourse (b, cnb)
|
||||
|
||||
-- let rank (s, cn) c = Seq.elemIndexL c $ studentPrefs cstb (s, cn)
|
||||
-- caRa <- hoistMaybe $ rank (a, cna) ca
|
||||
-- caRb <- hoistMaybe $ rank (b, cnb) ca
|
||||
-- cbRa <- hoistMaybe $ rank (a, cna) cb
|
||||
-- cbRb <- hoistMaybe $ rank (b, cnb) cb
|
||||
|
||||
-- let currentRanks cop = caRa `cop` cbRb
|
||||
-- newRanks cop = cbRa `cop` caRb
|
||||
|
||||
-- swapImproves = or
|
||||
-- [ currentRanks (+) > newRanks (+)
|
||||
-- , currentRanks (+) == newRanks (+)
|
||||
-- && currentRanks min > newRanks min
|
||||
-- ]
|
||||
-- lift . when swapImproves $ do
|
||||
-- traceM $ show (a, cna) <> " `swap` " <> show (b, cnb)
|
||||
-- let
|
||||
-- addCourseUser :: course -> (student, CloneIndex) -> ST s ()
|
||||
-- addCourseUser c (st, cn) = do
|
||||
-- cState <- MArr.readArray courses' c
|
||||
-- case cState of
|
||||
-- Left pSet ->
|
||||
-- MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet)
|
||||
-- Right spots ->
|
||||
-- let (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots
|
||||
-- isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of
|
||||
-- EQ -> error "Two student-clones compared equal in the face of stb"
|
||||
-- GT -> False
|
||||
-- LT -> True
|
||||
-- newSpots = force $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
-- in MArr.writeArray courses' c $ Right newSpots
|
||||
-- remCourseUser :: course -> (student, CloneIndex) -> ST s ()
|
||||
-- remCourseUser c (st, cn) = do
|
||||
-- cState <- MArr.readArray courses' c
|
||||
-- case cState of
|
||||
-- Left pSet ->
|
||||
-- MArr.writeArray courses' c $!! Left (Set.delete (st, cn) pSet)
|
||||
-- Right spots ->
|
||||
-- MArr.writeArray courses' c $!! Right (Seq.filter (/= (st, cn)) spots)
|
||||
|
||||
-- remCourseUser ca (a, cna)
|
||||
-- remCourseUser cb (b, cnb)
|
||||
-- addCourseUser cb (a, cna)
|
||||
-- addCourseUser ca (b, cnb)
|
||||
|
||||
-- lift pairwiseExchange
|
||||
|
||||
|
||||
courseMatchings <- lift . lift $ MArr.getAssocs courses'
|
||||
return . Set.fromList $ do
|
||||
(review contCourses -> course, students) <- courseMatchings
|
||||
student <- case students of
|
||||
Left pSet -> view _1 <$> toList pSet
|
||||
Right spots -> view _1 <$> toList spots
|
||||
return (student, course)
|
||||
|
||||
courseRating :: course -> (student, CloneIndex) -> Maybe courseRatingStudent'
|
||||
courseRating c (st, cn) = do
|
||||
(_, courseRating') <- preferences Map.!? (st, c)
|
||||
return $ centralNudge st (fromIntegral cn) courseRating'
|
||||
|
||||
clonedStudents :: Set (student, CloneIndex)
|
||||
clonedStudents = Set.fromDistinctAscList $ do
|
||||
(student, clones) <- Map.toAscList cloneCounts
|
||||
clone <- [0,1..pred $ fromIntegral clones]
|
||||
return (student, clone)
|
||||
|
||||
contStudents :: Iso' student StudentIndex
|
||||
contStudents = iso toInt fromInt
|
||||
where
|
||||
students' = Map.keys cloneCounts
|
||||
|
||||
toInt = fromMaybe (error "trying to resolve unknown student") . flip elemIndex students'
|
||||
fromInt = (!!) students'
|
||||
|
||||
studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex))
|
||||
studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts))
|
||||
|
||||
courses :: Set course
|
||||
courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities
|
||||
courseBounds :: (CourseIndex, CourseIndex)
|
||||
courseBounds = (0, pred $ Set.size courses)
|
||||
|
||||
contCourses :: Iso' course CourseIndex
|
||||
contCourses = iso toInt fromInt
|
||||
where
|
||||
courses' = Set.toAscList courses
|
||||
|
||||
toInt = fromMaybe (error "trying to resolve unknown course") . flip elemIndex courses'
|
||||
fromInt = (!!) courses'
|
||||
|
||||
initCourse :: course -> Either (Set (student, CloneIndex)) (Seq (student, CloneIndex))
|
||||
initCourse c
|
||||
| is _Just . join $ Map.lookup c capacities
|
||||
= Right Seq.empty
|
||||
| otherwise
|
||||
= Left Set.empty
|
||||
|
||||
studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> [course]
|
||||
studentPrefs cstb (st, _) = map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses
|
||||
where
|
||||
cPref :: course -> Maybe (studentRatingCourse, a)
|
||||
cPref c = do
|
||||
(cPref', _) <- Map.lookup (st, c) preferences
|
||||
return (cPref', cstb c)
|
||||
@ -196,6 +196,7 @@ data FormIdentifier
|
||||
| FIDcourseRegister
|
||||
| FIDsheet
|
||||
| FIDmaterial
|
||||
| FIDCourseNews
|
||||
| FIDsubmission
|
||||
| FIDsettings
|
||||
| FIDcorrectors
|
||||
|
||||
@ -19,10 +19,14 @@ import Utils.Lens.TH as Utils.Lens
|
||||
import Data.Set.Lens as Utils.Lens
|
||||
import Data.Map.Lens as Utils.Lens
|
||||
|
||||
import Data.Generics.Product.Types as Utils.Lens
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
_PathPiece :: PathPiece v => Prism' Text v
|
||||
_PathPiece = prism' toPathPiece fromPathPiece
|
||||
@ -48,6 +52,9 @@ _SchoolId = iso unSchoolKey SchoolKey
|
||||
_Maybe :: Iso' (Maybe ()) Bool
|
||||
_Maybe = iso (is _Just) (bool Nothing (Just ()))
|
||||
|
||||
_CI :: FoldCase s => Iso' (CI s) s
|
||||
_CI = iso CI.original CI.mk
|
||||
|
||||
|
||||
-----------------------------------
|
||||
-- Lens Definitions for our Types
|
||||
@ -197,6 +204,10 @@ makeLenses_ ''SchoolLdap
|
||||
makeLenses_ ''UserFunction
|
||||
|
||||
makeLenses_ ''CourseUserExamOfficeOptOut
|
||||
|
||||
makeLenses_ ''CourseNewsFile
|
||||
|
||||
makeLenses_ ''AllocationCourse
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
@ -58,5 +58,7 @@ extra-deps:
|
||||
|
||||
- process-1.6.5.1
|
||||
|
||||
- generic-lens-1.2.0.0
|
||||
|
||||
resolver: lts-13.21
|
||||
allow-newer: true
|
||||
|
||||
@ -235,6 +235,13 @@ packages:
|
||||
sha256: 19d944da6aa37944332e0726372288319852e5f72aa57dbc3516dc15e760a502
|
||||
original:
|
||||
hackage: process-1.6.5.1
|
||||
- completed:
|
||||
hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
|
||||
pantry-tree:
|
||||
size: 4315
|
||||
sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0
|
||||
original:
|
||||
hackage: generic-lens-1.2.0.0
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 498180
|
||||
|
||||
@ -1,13 +1,24 @@
|
||||
$newline never
|
||||
<section>
|
||||
$# <h2>
|
||||
$# _{MsgAllocationData}
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationSemester}
|
||||
<dd .deflist__dd>
|
||||
_{unTermKey allocationTerm}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationSchool}
|
||||
<dd .deflist__dd>
|
||||
#{schoolName}
|
||||
$maybe desc <- allocationDescription
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationDescription}
|
||||
<dd .deflist__dd>
|
||||
#{desc}
|
||||
$maybe desc <- guardOn isAnyLecturer =<< allocationStaffDescription
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationStaffDescription}
|
||||
<dd .deflist__dd>
|
||||
#{desc}
|
||||
$maybe fromT <- allocationStaffRegisterFrom
|
||||
<dt .deflist__dt>
|
||||
$maybe _ <- allocationStaffRegisterTo
|
||||
@ -32,14 +43,36 @@ $newline never
|
||||
_{MsgAllocationStaffAllocationFrom}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
|
||||
|
||||
$# TODO show datetime of automatic allocation
|
||||
$#
|
||||
$# <dt .deflist__dt>
|
||||
$# _{MsgAllocationProcess}
|
||||
$# <dd .deflist__dd>
|
||||
$# ^{formatTimeRangeW SelFormatDateTime fromT allocationProcess}
|
||||
$#
|
||||
$maybe fromT <- allocationRegisterByStaffFrom
|
||||
<dt .deflist__dt>
|
||||
$maybe _ <- allocationRegisterByStaffTo
|
||||
_{MsgAllocationRegisterByStaff}
|
||||
<span .tooltip>
|
||||
<span .tooltip__handle>
|
||||
<span .tooltip__content>
|
||||
_{MsgAllocationRegisterByStaffTip}
|
||||
$nothing
|
||||
_{MsgAllocationRegisterByStaffFrom}
|
||||
<span .tooltip>
|
||||
<span .tooltip__handle>
|
||||
<span .tooltip__content>
|
||||
_{MsgAllocationRegisterByStaffFromTip}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo}
|
||||
$maybe fromT <- allocationRegisterByCourse
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationRegisterByCourseFrom}
|
||||
<span .tooltip>
|
||||
<span .tooltip__handle>
|
||||
<span .tooltip__content>
|
||||
_{MsgAllocationRegisterByCourseFromTip}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime fromT}
|
||||
$maybe toT <- allocationOverrideDeregister
|
||||
<dt .deflist__dt>
|
||||
_{MsgAllocationOverrideDeregister}
|
||||
<dd .deflist__dd>
|
||||
<p>^{formatTimeW SelFormatDateTime toT}
|
||||
|
||||
<section id=allocation-participation>
|
||||
<h2>
|
||||
|
||||
@ -17,10 +17,11 @@
|
||||
display: grid;
|
||||
grid-template-columns: minmax(105px, 1fr) 9fr;
|
||||
grid-template-areas:
|
||||
'name name '
|
||||
'prio-label prio '
|
||||
'instr-label instr '
|
||||
'form-label form ';
|
||||
'name name '
|
||||
'. registered '
|
||||
'prio-label prio '
|
||||
'instr-label instr '
|
||||
'form-label form ';
|
||||
|
||||
grid-gap: 5px 7px;
|
||||
margin: 12px 0;
|
||||
@ -41,6 +42,10 @@
|
||||
background-color: rgba(0, 0, 0, 0.015);
|
||||
}
|
||||
|
||||
.allocation-course__registered {
|
||||
grid-area: registered;
|
||||
}
|
||||
|
||||
.allocation-course__priority {
|
||||
grid-area: prio;
|
||||
}
|
||||
@ -84,6 +89,7 @@
|
||||
grid-template-columns: 1fr;
|
||||
grid-template-areas:
|
||||
'name '
|
||||
'registered '
|
||||
'prio-label '
|
||||
'prio '
|
||||
'instr-label'
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
$if isRegistered
|
||||
<div .allocation-course__registered>
|
||||
#{iconOK}
|
||||
\ _{MsgRegistered}
|
||||
$if is _Just muid
|
||||
<div .allocation-course__priority-label .allocation__label>
|
||||
_{MsgAllocationPriority}
|
||||
|
||||
12
templates/course-news.hamlet
Normal file
12
templates/course-news.hamlet
Normal file
@ -0,0 +1,12 @@
|
||||
$newline never
|
||||
$maybe summary <- courseNewsSummary
|
||||
<section>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
_{MsgCourseNewsSummary}
|
||||
<dd .deflist__dd>
|
||||
#{summary}
|
||||
<section>
|
||||
#{courseNewsContent}
|
||||
$nothing
|
||||
#{courseNewsContent}
|
||||
@ -1,16 +1,78 @@
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>Fakultät/Institut
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{schoolName}
|
||||
|
||||
$if not (null news) || mayCreateNews
|
||||
<dt .deflist__dt>
|
||||
_{MsgCourseNews}
|
||||
$if not visibleNews
|
||||
\ #{iconInvisible}
|
||||
<dd .deflist__dd>
|
||||
$if not (null news)
|
||||
<ul .course-news .list--iconless>
|
||||
$forall (cID, CourseNews{courseNewsTitle, courseNewsSummary, courseNewsContent}, isVisible, files, lastEditText, mayEdit, mayDelete) <- news
|
||||
<li .course-news-item ##{"news-" <> toPathPiece cID}>
|
||||
$case (courseNewsTitle, courseNewsSummary)
|
||||
$# $of (Just title, Just summary)
|
||||
$# <div .div-h3 .course-news-item__title>
|
||||
$# ^{modal (toWidget title) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
|
||||
$# $if not isVisible
|
||||
$# \ #{iconInvisible}
|
||||
$# <p .course-news-item__summary>
|
||||
$# #{summary}
|
||||
$of (_, Just summary)
|
||||
$if not isVisible
|
||||
<h3 .course-news-item__title>
|
||||
#{iconInvisible}
|
||||
<div .div-p .course-news-item__summary>
|
||||
^{modal (toWidget summary) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
|
||||
$of (Just title, Nothing)
|
||||
<h3 .course-news-item__title>
|
||||
#{title}
|
||||
$if not isVisible
|
||||
\ #{iconInvisible}
|
||||
<p .course-news-item__content>
|
||||
#{courseNewsContent}
|
||||
$of (Nothing, Nothing)
|
||||
$if not isVisible
|
||||
<h3 .course-news-item__title>
|
||||
#{iconInvisible}
|
||||
<p .course-news-item__content>
|
||||
#{courseNewsContent}
|
||||
$if showNewsFiles files
|
||||
<ul .course-news-item__files-links .list--inline .list--comma-separated>
|
||||
$forall (_, fp) <- filter (not . view _1) files
|
||||
<li .course-news-item__file-link>
|
||||
<a href=@{CNewsR tid ssh csh cID (CNFileR fp)}>
|
||||
#{fp}
|
||||
$elseif not (null files)
|
||||
<p .course-news-item__files-link>
|
||||
<a href=@{CNewsR tid ssh csh cID CNArchiveR}>
|
||||
#{iconFileZip}
|
||||
\ _{MsgCourseNewsFiles}
|
||||
<p .course-news-item__last-edit>
|
||||
_{MsgCourseNewsLastEdited lastEditText}
|
||||
$if mayEdit || mayDelete
|
||||
<ul .course-news-item__actions .list--inline .list--comma-separated>
|
||||
$if mayEdit
|
||||
<li>
|
||||
^{modal (i18n MsgCourseNewsActionEdit) (Left (SomeRoute (CNewsR tid ssh csh cID CNEditR)))}
|
||||
$if mayDelete
|
||||
<li>
|
||||
^{modal (i18n MsgCourseNewsActionDelete) (Left (SomeRoute (CNewsR tid ssh csh cID CNDeleteR)))}
|
||||
$if mayCreateNews
|
||||
<div .div-p>
|
||||
^{modal (i18n MsgCourseNewsActionCreate) (Left (SomeRoute (CourseR tid ssh csh CNewsNewR)))}
|
||||
|
||||
|
||||
$maybe descr <- courseDescription course
|
||||
<dt .deflist__dt>_{MsgCourseDescription}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{descr}
|
||||
|
||||
<dt .deflist__dt>_{MsgCourseSchool}
|
||||
<dd .deflist__dd>
|
||||
#{schoolName}
|
||||
|
||||
$with numlecs <- length lecturers
|
||||
$if numlecs /= 0
|
||||
$if numlecs > 1
|
||||
@ -18,10 +80,9 @@ $newline never
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgLecturerFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall lect <- lecturers
|
||||
<li>^{nameEmailWidget' lect}
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall lect <- lecturers
|
||||
<li>^{nameEmailWidget' lect}
|
||||
$with numassi <- length assistants
|
||||
$if numassi /= 0
|
||||
$if numassi > 1
|
||||
@ -29,58 +90,64 @@ $newline never
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgAssistantFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall assi <- assistants
|
||||
<li>^{nameEmailWidget' assi}
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall assi <- assistants
|
||||
<li>^{nameEmailWidget' assi}
|
||||
|
||||
$with numtutor <- length tutors
|
||||
$if numtutor /= 0
|
||||
<dt .deflist__dt>_{MsgTutorsFor numtutor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutors
|
||||
<li>^{nameEmailWidget' tutor}
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutors
|
||||
<li>^{nameEmailWidget' tutor}
|
||||
|
||||
$with numcorrector <- length correctors
|
||||
$if numcorrector /= 0
|
||||
<dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall corrector <- correctors
|
||||
<li>^{nameEmailWidget' corrector}
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall corrector <- correctors
|
||||
<li>^{nameEmailWidget' corrector}
|
||||
|
||||
$maybe link <- courseLinkExternal course
|
||||
<dt .deflist__dt>Website
|
||||
<dt .deflist__dt>_{MsgCourseHomepageExternal}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
|
||||
<a href=#{link} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
|
||||
#{iconLink}
|
||||
\ #{link}
|
||||
$# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
<dt .deflist__dt>Teilnehmer
|
||||
<dt .deflist__dt>_{MsgCourseParticipantsHeading}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{participants}
|
||||
$maybe capacity <- courseCapacity course
|
||||
\ von #{capacity}
|
||||
$maybe (name, url) <- mAllocation'
|
||||
$maybe capacity <- courseCapacity course
|
||||
_{MsgCourseParticipantsCountOf participants capacity}
|
||||
$nothing
|
||||
_{MsgCourseParticipantsCount participants}
|
||||
$maybe (Allocation{allocationName, allocationRegisterByCourse}, url) <- mAllocation'
|
||||
<dt .deflist__dt>_{MsgCourseAllocation}
|
||||
<dd .deflist__dd>
|
||||
<a href=#{url}>
|
||||
#{name}
|
||||
#{allocationName}
|
||||
$maybe regFrom <- allocationRegisterByCourse
|
||||
$maybe regFrom' <- courseRegisterFrom course
|
||||
$with regFrom'' <- max regFrom regFrom'
|
||||
$if NTop (Just regFrom'') <= NTop (courseRegisterTo course)
|
||||
<dt .deflist__dt>_{MsgCourseDirectRegistrationInterval}
|
||||
<dd .deflist__dd>
|
||||
<p>
|
||||
^{formatTimeRangeW SelFormatDateTime regFrom'' (courseRegisterTo course)}
|
||||
$maybe dereg <- mDereg
|
||||
<p .emph>
|
||||
_{MsgCourseDeregisterUntil dereg}
|
||||
$nothing
|
||||
$maybe regFrom <- mRegFrom
|
||||
<dt .deflist__dt>Anmeldezeitraum
|
||||
$maybe regFrom <- courseRegisterFrom course
|
||||
<dt .deflist__dt>_{MsgCourseRegistrationInterval}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
Ab #{regFrom}
|
||||
$maybe regTo <- mRegTo
|
||||
\ bis #{regTo}
|
||||
<p>
|
||||
^{formatTimeRangeW SelFormatDateTime regFrom (courseRegisterTo course)}
|
||||
$maybe dereg <- mDereg
|
||||
<div>
|
||||
\ <em>Achtung:</em>
|
||||
\ Abmeldung nur bis #{dereg} erlaubt.
|
||||
<p .emph>
|
||||
_{MsgCourseDeregisterUntil dereg}
|
||||
$maybe aInst <- courseApplicationsInstructions course
|
||||
<dt .deflist__dt>
|
||||
$if courseApplicationsRequired course
|
||||
@ -98,7 +165,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
_{MsgCourseApplicationTemplateApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationTemplateRegistration}
|
||||
$if registrationOpen || isJust mRegAt
|
||||
$if registrationOpen || isJust registration
|
||||
<dt .deflist__dt>
|
||||
_{MsgCourseRegistration}
|
||||
<dd .deflist__dd>
|
||||
@ -110,20 +177,19 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
<p>
|
||||
_{MsgCourseApplicationDeleteToEdit}
|
||||
$else
|
||||
$if isJust mRegAt
|
||||
$if isJust registration
|
||||
<p>
|
||||
_{MsgCourseRegistrationDeleteToEdit}
|
||||
$maybe date <- mRegAt
|
||||
_{MsgRegisteredSince} #{date}
|
||||
$maybe CourseParticipant{courseParticipantRegistration} <- registration
|
||||
_{MsgRegisteredSince}
|
||||
\ ^{formatTimeW SelFormatDateTime courseParticipantRegistration}
|
||||
<dt .deflist__dt>
|
||||
Material
|
||||
_{MsgCourseMaterial}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
$if courseMaterialFree course
|
||||
Das Kursmaterial ist ohne Anmeldung frei zugänglich.
|
||||
$else
|
||||
Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
|
||||
(z.B. Übungsblätter).
|
||||
$if courseMaterialFree course
|
||||
_{MsgCourseMaterialFree}
|
||||
$else
|
||||
_{MsgCourseMaterialNotFree}
|
||||
$if hasExams
|
||||
<dt .deflist__dt>_{MsgCourseExams}
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -6,3 +6,37 @@ th {
|
||||
th, td {
|
||||
padding-bottom: 7px;
|
||||
}
|
||||
|
||||
.course-news {
|
||||
max-height: 50vh;
|
||||
overflow: auto;
|
||||
|
||||
.course-news-item {
|
||||
padding: 12px 0;
|
||||
border-bottom: 1px solid #d3d3d3;
|
||||
|
||||
&:last-child {
|
||||
padding-bottom: 0;
|
||||
border-bottom: none;
|
||||
}
|
||||
|
||||
&:first-child {
|
||||
padding-top: 0;
|
||||
}
|
||||
|
||||
.course-news-item__last-edit {
|
||||
color: var(--color-fontsec);
|
||||
font-style: italic;
|
||||
}
|
||||
|
||||
.course-news-item__title .modal__trigger-label {
|
||||
font-style: normal;
|
||||
}
|
||||
|
||||
.course-news-item__summary .modal__trigger-label {
|
||||
font-weight: normal;
|
||||
font-style: normal;
|
||||
color: var(--color-font);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -108,6 +108,10 @@ body {
|
||||
|
||||
/* END THEMES */
|
||||
|
||||
.emph {
|
||||
font-style: italic;
|
||||
}
|
||||
|
||||
a,
|
||||
a:visited {
|
||||
text-decoration: none;
|
||||
@ -128,7 +132,7 @@ ul {
|
||||
margin-left: 20px;
|
||||
}
|
||||
|
||||
h1, h2, h3, h4, h5 {
|
||||
h1, h2, h3, .div-h3 , h4, h5 {
|
||||
font-weight: 600;
|
||||
}
|
||||
h1 {
|
||||
@ -138,10 +142,18 @@ h1 {
|
||||
h2 {
|
||||
font-size: 24px;
|
||||
margin: 10px 0;
|
||||
|
||||
&:first-child {
|
||||
margin-top: 0;
|
||||
}
|
||||
}
|
||||
h3 {
|
||||
h3, .div-h3 {
|
||||
font-size: 20px;
|
||||
margin: 10px 0;
|
||||
|
||||
&:first-child {
|
||||
margin-top: 0;
|
||||
}
|
||||
}
|
||||
h4 {
|
||||
font-size: 16px;
|
||||
@ -158,7 +170,7 @@ h4 {
|
||||
font-size: 20px;
|
||||
}
|
||||
|
||||
h3 {
|
||||
h3, .div-h3 {
|
||||
font-size: 16px;
|
||||
}
|
||||
}
|
||||
@ -185,7 +197,7 @@ h4 {
|
||||
text-decoration: underline;
|
||||
}
|
||||
|
||||
p, form {
|
||||
p, form, .div-p {
|
||||
margin: 0.5rem 0;
|
||||
|
||||
&:last-child {
|
||||
@ -538,7 +550,7 @@ ul.list--inline {
|
||||
font-size: 18px;
|
||||
margin-bottom: 10px;
|
||||
|
||||
> p {
|
||||
> p, > .div-p {
|
||||
margin-top: 0;
|
||||
}
|
||||
}
|
||||
@ -647,6 +659,13 @@ section {
|
||||
grid-template-columns: 1fr 3fr;
|
||||
grid-gap: 5px;
|
||||
|
||||
fieldset {
|
||||
display: grid;
|
||||
grid-template-columns: 1fr 3fr;
|
||||
grid-gap: 5px;
|
||||
grid-column: 1/3;
|
||||
}
|
||||
|
||||
.notification {
|
||||
margin: 0;
|
||||
}
|
||||
@ -664,6 +683,11 @@ section {
|
||||
.form-section-notification {
|
||||
grid-template-columns: 1fr;
|
||||
margin-top: 17px;
|
||||
|
||||
fieldset {
|
||||
grid-template-columns: 1fr;
|
||||
grid-column: 1/2;
|
||||
}
|
||||
}
|
||||
|
||||
.notification {
|
||||
|
||||
@ -29,12 +29,13 @@ $newline text
|
||||
Studierende können sich nur in diesem Zeitraum
|
||||
auf Plätze in Kursen einer Zentralanmeldung bewerben.
|
||||
<p>
|
||||
Bewerber können jedem Kurs der Zentralanmeldung eine Priorität
|
||||
zuweisen, zwischen "dieser Kurs wäre meine erste Wahl"
|
||||
und "diesen Kurs besuche ich auf keinen Fall".
|
||||
Bewerber können jedem Kurs der Zentralanmeldung eine Priorität zuweisen,
|
||||
zwischen "dieser Kurs wäre meine erste Wahl" und "diesen Kurs besuche
|
||||
ich nur, wenn ich keinen anderen Platz kriege".
|
||||
Es kann auch mehreren Kursen die gleiche Priorität eingeräumt werden.
|
||||
<p>
|
||||
Bewerbungen für und Prioritisierung der Kurse können innerhalb des Bewerbungszeitraums beliebig angepasst und zurückgezogen werden.
|
||||
Bewerbungen für und Prioritisierung der Kurse können innerhalb des
|
||||
Bewerbungszeitraums beliebig angepasst und zurückgezogen werden.
|
||||
<p>
|
||||
Studierende können auch mehr als einen Platz
|
||||
in verschiedenen Kursen einer Zentralanmeldung anfordern,
|
||||
@ -64,7 +65,6 @@ $newline text
|
||||
und der Bewertung durch den Veranstalter auf die Bewerber verteilt.
|
||||
<p>
|
||||
Die Bewerber werden diekt in den jeweiligen Kursen angemeldet.
|
||||
Eine Abmeldung durch Studierende ist nicht erlaubt.
|
||||
Übernommene Bewerber, welche einen zugeteilten Platz
|
||||
ohne Angabe eines triftigen Grundes nicht antreten,
|
||||
werden in zukünftigen Zentralanmeldungen
|
||||
@ -78,9 +78,8 @@ $newline text
|
||||
Der Ablauf einer Zentralanmeldung kann unter Umständen noch variieren.
|
||||
<em>
|
||||
Insbesondere: #
|
||||
Fehlt in der Übersichtsseite einer Zentralanmeldung
|
||||
die Angabe einer dieser Phasen, dann wurde der entsprechende Zeitraum
|
||||
leider noch nicht festgelegt!
|
||||
Fehlt in der Übersichtsseite einer Zentralanmeldung die Angabe einer dieser
|
||||
Phasen, dann wurden die entsprechenden Zeiten noch nicht festgelegt!
|
||||
<p>
|
||||
Mehrere Zentralanmeldungen werden völlig unabhängig voneinander
|
||||
abgewickelt.
|
||||
|
||||
@ -1,5 +1,11 @@
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
^{formatGregorianW 2019 10 01}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
<li>"Aktuelles" für Kurse
|
||||
|
||||
<dt .deflist__dt>
|
||||
^{formatGregorianW 2019 09 27}
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -97,6 +97,15 @@ $newline text
|
||||
<a href=@{AuthPredsR}>Berechtigungen hier temporär selbst entziehen
|
||||
. Um die eigene Veranstaltung aus Sicht eines Teilnehmers zu sehen, deaktiviert man #
|
||||
die Berechtigungsprüfungen "_{MsgAuthTagLecturer}" und/oder "_{MsgAuthTagCorrector}"
|
||||
|
||||
<dt .deflist__dt> Aktuelles
|
||||
<dd .deflist__dd>
|
||||
<p>
|
||||
Es lassen sich, direkt auf der Kursübersichtsseite, Neuigkeiten in Bezug
|
||||
auf die Veranstaltung auf der Übersichtsseite publizieren ("Aktuelles").
|
||||
<p>
|
||||
In Zukunft sind ein RSS-Feed und (opt-in) E-Mail-Benachrichtigungen
|
||||
hierfür geplant.
|
||||
|
||||
<section>
|
||||
<h2>Übungsbetrieb
|
||||
|
||||
36
templates/mail/allocationResults.hamlet
Normal file
36
templates/mail/allocationResults.hamlet
Normal file
@ -0,0 +1,36 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
_{SomeMessage $ MsgMailSubjectAllocationResults allocationName}
|
||||
|
||||
$if not (null lecturerResults)
|
||||
<p>
|
||||
_{SomeMessage MsgAllocationResultsLecturer}
|
||||
<ul>
|
||||
$forall msg <- lecturerResults
|
||||
<li>_{msg}
|
||||
|
||||
$maybe pResults <- participantResults
|
||||
$case pResults
|
||||
$of []
|
||||
<p>_{SomeMessage MsgAllocationNoResultsStudent}
|
||||
$of [csh]
|
||||
<p>_{SomeMessage $ MsgAllocationResultStudent csh}
|
||||
$of cshs
|
||||
<p>
|
||||
_{SomeMessage MsgAllocationResultsStudent}
|
||||
<ul>
|
||||
$forall csh <- cshs
|
||||
<li>#{csh}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
@ -12,20 +12,24 @@ $newline never
|
||||
<div .asidenav__box>
|
||||
<h3 .asidenav__box-title uw-show-hide data-show-hide-id="#{termToText tid}" data-show-hide-align=right>
|
||||
_{ShortTermIdentifier tid}
|
||||
<ul .asidenav__list.list--iconless>
|
||||
$forall (Course{courseShorthand, courseName}, courseRoute, pageActions) <- favouriteTerm tid
|
||||
<li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
|
||||
<a .asidenav__link-wrapper href=@{courseRoute}>
|
||||
<div .asidenav__link-shorthand>#{courseShorthand}
|
||||
<div .asidenav__link-label>#{courseName}
|
||||
<div .asidenav__nested-list-wrapper>
|
||||
<ul .asidenav__nested-list.list--iconless>
|
||||
$forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
|
||||
$case menuItemType
|
||||
$of PageActionPrime
|
||||
<li .asidenav__nested-list-item>
|
||||
<a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
|
||||
$of _
|
||||
$forall favReason <- sortOn Down universeF
|
||||
$if not (null $ favouriteTermReason tid favReason)
|
||||
<h3 .asidenav__box-subtitle>
|
||||
_{favReason}
|
||||
<ul .asidenav__list.list--iconless>
|
||||
$forall (Course{courseShorthand, courseName}, courseRoute, pageActions, _) <- favouriteTermReason tid favReason
|
||||
<li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
|
||||
<a .asidenav__link-wrapper href=@{courseRoute}>
|
||||
<div .asidenav__link-shorthand>#{courseShorthand}
|
||||
<div .asidenav__link-label>#{courseName}
|
||||
<div .asidenav__nested-list-wrapper>
|
||||
<ul .asidenav__nested-list.list--iconless>
|
||||
$forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
|
||||
$case menuItemType
|
||||
$of PageActionPrime
|
||||
<li .asidenav__nested-list-item>
|
||||
<a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
|
||||
$of _
|
||||
|
||||
<div .asidenav__sigillum>
|
||||
<img src=@{StaticR img_lmu_sigillum_svg}>
|
||||
|
||||
@ -1,10 +1,21 @@
|
||||
<p>_{drCaption}
|
||||
<ul>
|
||||
$forall (wdgt, _) <- targets
|
||||
<li>
|
||||
^{wdgt}
|
||||
$newline never
|
||||
|
||||
<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
|
||||
<p>_{drCaption}
|
||||
|
||||
$case targets
|
||||
$of [(wdgt, _)]
|
||||
<p>^{wdgt}
|
||||
$of _
|
||||
<ul>
|
||||
$forall (wdgt, _) <- targets
|
||||
<li>
|
||||
^{wdgt}
|
||||
|
||||
<p>
|
||||
$if Text.null (Text.strip confirmString)
|
||||
_{SomeMessage $ MsgDeletePressButtonIfSure (Set.size drRecords)}
|
||||
$else
|
||||
_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
|
||||
|
||||
<p .confirmationText>
|
||||
#{confirmString}
|
||||
|
||||
@ -101,6 +101,7 @@ fillDb = do
|
||||
, userFirstName = "Gregor Julius Arthur"
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = 6
|
||||
, userMaxFavouriteTerms = 1
|
||||
, userTheme = ThemeDefault
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
@ -126,6 +127,7 @@ fillDb = do
|
||||
, userFirstName = "Felix"
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = ThemeDefault
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
@ -151,6 +153,7 @@ fillDb = do
|
||||
, userFirstName = "Steffen"
|
||||
, userTitle = Just "Dr."
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = ThemeMossGreen
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
@ -178,6 +181,7 @@ fillDb = do
|
||||
, userMaxFavourites = 7
|
||||
, userTheme = ThemeAberdeenReds
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
@ -201,6 +205,7 @@ fillDb = do
|
||||
, userFirstName = "Sabrina"
|
||||
, userTitle = Just "Magister"
|
||||
, userMaxFavourites = 5
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = ThemeAberdeenReds
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
@ -226,6 +231,7 @@ fillDb = do
|
||||
, userFirstName = "Sarah"
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = ThemeMossGreen
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
@ -469,7 +475,7 @@ fillDb = do
|
||||
insert_ $ SheetEdit gkleen now feste
|
||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMs)
|
||||
,(tinaTester, Just sfTTc)
|
||||
@ -592,7 +598,7 @@ fillDb = do
|
||||
insert_ $ CourseEdit jost now pmo
|
||||
void . insert $ DegreeCourse pmo sdBsc sdInf
|
||||
void . insert $ Lecturer jost pmo CourseAssistant
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMp)
|
||||
,(tinaTester, Just sfTTb)
|
||||
@ -779,6 +785,8 @@ fillDb = do
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just now
|
||||
, allocationFingerprint = Nothing
|
||||
, allocationMatchingLog = Nothing
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
insert_ $ AllocationCourse funAlloc ffp 2
|
||||
|
||||
@ -65,6 +65,10 @@ instance Arbitrary ExamOfficeR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary CourseNewsR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Route UniWorX) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -92,6 +92,7 @@ instance Arbitrary User where
|
||||
userTitle <- fmap (pack . getPrintableString) <$> arbitrary
|
||||
|
||||
userMaxFavourites <- getNonNegative <$> arbitrary
|
||||
userMaxFavouriteTerms <- getNonNegative <$> arbitrary
|
||||
userTheme <- arbitrary
|
||||
|
||||
let genDateTimeFormat sel = do
|
||||
|
||||
@ -131,6 +131,7 @@ createUser adjUser = do
|
||||
userTitle = Nothing
|
||||
userTheme = userDefaultTheme
|
||||
userMaxFavourites = userDefaultMaxFavourites
|
||||
userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
userDateTimeFormat = userDefaultDateTimeFormat
|
||||
userDateFormat = userDefaultDateFormat
|
||||
userTimeFormat = userDefaultTimeFormat
|
||||
|
||||
160
test/Utils/AllocationSpec.hs
Normal file
160
test/Utils/AllocationSpec.hs
Normal file
@ -0,0 +1,160 @@
|
||||
module Utils.AllocationSpec where
|
||||
|
||||
import TestImport hiding (Course)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Random (mkStdGen)
|
||||
|
||||
|
||||
data Man = Alpha | Beta | Gamma | Delta
|
||||
deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
|
||||
instance NFData Man
|
||||
|
||||
data Woman = Alef | Bet | Gimel | Dalet
|
||||
deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "computeMatching" $
|
||||
it "produces some expected known matchings" $ do
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 2))
|
||||
, ((Alpha, Gimel), (3, 1))
|
||||
, ((Beta , Alef ), (3, 1))
|
||||
, ((Beta , Bet ), (1, 3))
|
||||
, ((Beta , Gimel), (2, 2))
|
||||
, ((Gamma, Alef ), (2, 2))
|
||||
, ((Gamma, Bet ), (3, 1))
|
||||
, ((Gamma, Gimel), (1, 3))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 2) <$> [Alpha,Beta,Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 2))
|
||||
, ((Alpha, Gimel), (3, 1))
|
||||
, ((Beta , Alef ), (3, 1))
|
||||
, ((Beta , Bet ), (1, 3))
|
||||
, ((Beta , Gimel), (2, 2))
|
||||
, ((Delta, Alef ), (2, 2))
|
||||
, ((Delta, Bet ), (3, 1))
|
||||
, ((Delta, Gimel), (1, 3))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Delta, Gimel)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma]
|
||||
women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 2))
|
||||
, ((Alpha, Gimel), (3, 1))
|
||||
, ((Beta , Alef ), (3, 1))
|
||||
, ((Beta , Bet ), (1, 3))
|
||||
, ((Beta , Gimel), (2, 2))
|
||||
, ((Gamma, Alef ), (2, 2))
|
||||
, ((Gamma, Bet ), (3, 1))
|
||||
, ((Gamma, Gimel), (1, 3))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Alef), (Gamma, Alef), (Beta, Bet), (Alpha, Bet), (Beta, Gimel), (Gamma, Gimel)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 3))
|
||||
, ((Alpha, Gimel), (3, 2))
|
||||
, ((Alpha, Dalet), (4, 3))
|
||||
, ((Beta , Alef ), (1, 4))
|
||||
, ((Beta , Bet ), (4, 1))
|
||||
, ((Beta , Gimel), (3, 3))
|
||||
, ((Beta , Dalet), (2, 2))
|
||||
, ((Gamma, Alef ), (2, 2))
|
||||
, ((Gamma, Bet ), (1, 4))
|
||||
, ((Gamma, Gimel), (3, 4))
|
||||
, ((Gamma, Dalet), (4, 1))
|
||||
, ((Delta, Alef ), (4, 1))
|
||||
, ((Delta, Bet ), (2, 2))
|
||||
, ((Delta, Gimel), (3, 1))
|
||||
, ((Delta, Dalet), (1, 4))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 2))
|
||||
, ((Alpha, Gimel), (3, 1))
|
||||
, ((Alpha, Dalet), (4, 3))
|
||||
, ((Beta , Alef ), (1, 4))
|
||||
, ((Beta , Bet ), (2, 3))
|
||||
, ((Beta , Gimel), (3, 2))
|
||||
, ((Beta , Dalet), (4, 4))
|
||||
, ((Gamma, Alef ), (3, 1))
|
||||
, ((Gamma, Bet ), (1, 4))
|
||||
, ((Gamma, Gimel), (2, 3))
|
||||
, ((Gamma, Dalet), (4, 2))
|
||||
, ((Delta, Alef ), (2, 2))
|
||||
, ((Delta, Bet ), (3, 1))
|
||||
, ((Delta, Gimel), (1, 4))
|
||||
, ((Delta, Dalet), (4, 1))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int])
|
||||
colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char])
|
||||
student_preferences = Map.fromList
|
||||
[ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)
|
||||
, ((2, 'A'), 3), ((2, 'Z'), 1), ((2, 'C'), 2)
|
||||
, ((3, 'A'), 3), ((3, 'Z'), 2), ((3, 'C'), 1)
|
||||
, ((4, 'A'), 2), ((4, 'Z'), 3), ((4, 'C'), 1)
|
||||
, ((5, 'A'), 1), ((5, 'Z'), 3), ((5, 'C'), 2)
|
||||
, ((6, 'A'), 2), ((6, 'Z'), 1), ((6, 'C'), 6)
|
||||
]
|
||||
preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(1, 'A'), (2, 'A'), (3, 'Z'), (4, 'Z'), (5, 'C'), (6, 'C')]
|
||||
ourResult = computeMatching (mkStdGen 0) students colleges preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
Loading…
Reference in New Issue
Block a user