Merge branch 'master' into workflows

This commit is contained in:
Gregor Kleen 2020-09-29 09:43:40 +02:00
commit 653f7f30dd
286 changed files with 2127 additions and 1197 deletions

View File

@ -12,6 +12,7 @@
- ignore: { name: "Use ***" }
- ignore: { name: "Redundant void" }
- ignore: { name: "Too strict maybe" }
- ignore: { name: "Use Just" }
- arguments:
- -XQuasiQuotes

View File

@ -2,6 +2,24 @@
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.
## [20.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.1...v20.5.0) (2020-09-28)
### Features
* **allocations:** notify about new courses ([18921e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18921e06d1deeb41d705eabacc2d348bac76197f))
* **allocations:** show staff descriptions ([b359468](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b35946859309fbb526043194c8620c5fc0844809))
* **changelog:** implement changelog like faq ([d9d353f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d9d353fcb7652c46a15016b5d2f400162c8271ef))
* **exams:** check exam_discouraged_modes ([f9c50c8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9c50c80f22770f5376396923b8921eaac3e7216))
* **exams:** exam design & school exam rules ([f7bab3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f7bab3befc4c42cde430699681f8caf8a959ab39))
### Bug Fixes
* tests ([65e0688](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65e06882d2491da5e30b1401db6ecc81efcac58b))
* **allocations:** notify for new course upon registration ([9e0b43a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e0b43a60d26a05f6e1b9d4dae2b2f75dd52fff1))
* tests ([ca81f3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca81f3b0f2913431cbaf399c33ed30a21979ce69))
### [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23)

View File

@ -628,6 +628,11 @@ section
&.notification--broad
max-width: none
&:first-child
margin-top: 0
&:last-child
margin-bottom: 0
.form-section-notification
display: grid
grid-template-columns: 1fr 3fr
@ -1100,9 +1105,8 @@ th, td
pointer-events: none
#changelog
font-size: 14px
white-space: pre-wrap
font-family: var(--font-monospace)
max-height: 75vh
overflow: auto
#gitrev
font-size: 12px

View File

@ -790,6 +790,15 @@ FormBehaviour: Verhalten
FormCosmetics: Oberfläche
FormPersonalAppearance: Öffentliche Daten
FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse
FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen"
AllocNotifyNewCourseDefault: Systemweite Einstellung
AllocNotifyNewCourseForceOff: Nein
AllocNotifyNewCourseForceOn: Ja
BtnNotifyNewCourseForceOn: Benachrichtigen
BtnNotifyNewCourseForceOff: Nicht benachrichtigen
PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt.
PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
@ -1133,6 +1142,8 @@ NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs an
NotificationTriggerSubmissionUserCreated: Ich wurde als Mitabgebender zu einer Übungsblatt-Abgabe hinzugefügt
NotificationTriggerSubmissionEdited: Eine meiner Übungsblatt-Abgaben wurde verändert
NotificationTriggerSubmissionUserDeleted: Ich wurde als Mitabgebender von einer Übungsblatt-Abgabe entfernt
NotificationTriggerAllocationNewCourse: Es wurde ein neuer Kurs eingetragen zu einer Zentralanmeldungen, zu der ich meine Teilnahme registriert habe
NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden
NotificationTriggerKindAll: Für alle Benutzer
NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
@ -1837,6 +1848,39 @@ ExamFormOccurrences: Prüfungstermine/Räume
ExamFormAutomaticFunctions: Automatische Funktionen
ExamFormCorrection: Korrektur
ExamFormParts: Teile
ExamFormMode: Ausgestaltung der Prüfung
ExamModeFormNone: Keine Angabe
ExamModeFormCustom: Benutzerdefiniert
ExamModeFormAids: Erlaubte Hilfsmittel
ExamModeFormOnline: Online/Offline
ExamModeFormSynchronicity: Synchron/Asynchron
ExamModeFormRequiredEquipment: Erforderliche Hilfsmittel
ExamModeFormRequiredEquipmentIdentificationTip: Es wird stets ein Hinweis angezeigt, dass Teilnehmer sich ausweisen können müssen.
ExamShowAids: Erlaubte Hilfsmittel
ExamShowOnline: Online/Offline
ExamShowSynchronicity: Synchron/Asynchron
ExamShowRequiredEquipment: Erforderliche Hilfsmittel
ExamShowRequiredEquipmentNoneSet: Keine Angabe durch die Kursverwalter
ExamShowIdentificationRequired: Prüfungsteilnehmer müssen sich ausweisen können. Halten Sie dafür einen amtlichen Lichtbildausweis (Personalausweis, Reisepass, Aufenthaltstitel) und Ihren Studierendenausweis bereit.
ExamOpenBook: Open Book
ExamClosedBook: Closed Book
ExamOnline: Online
ExamOffline: Offline
ExamSynchronous: Synchron
ExamAsynchronous: Asynchron
ExamRequiredEquipmentNone: Nichts
ExamRequiredEquipmentPen: Stift
ExamRequiredEquipmentPaperPen: Stift & Papier
ExamRequiredEquipmentCalculatorPen: Stift & Taschenrechner
ExamRequiredEquipmentCalculatorPaperPen: Stift, Papier & Taschenrechner
ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & Mikrophon
ExamRequiredEquipmentMicrophoneInternet: Mikrophon
ExamCorrectors: Korrektoren
ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
@ -1889,6 +1933,10 @@ ExamFinishedMustBeAfterStart: "Ergebnisse sichtbar ab" muss nach Beginn liegen
ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Ergebnisse sichtbar ab" liegen
ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Beginn liegen
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Beginn" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann.
ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten
ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen
@ -2208,6 +2256,13 @@ ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
ApplicationRatingSection: Bewertung
ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren.
AllocationNotificationNewCourse: Benachrichtigung bei neuen Kursen
AllocationNotificationNewCourseTip: Wollen Sie per E-Mail benachrichtigt werden, wenn für diese Zentralanmeldung ein neuer Kurs eingetragen wird? Dies überschreibt die systemweite Einstellung in "Anpassen".
AllocationNotificationNewCourseSuccessForceOn: Sie werden benachrichtigt, wenn ein neuer Kurs eingetragen wird
AllocationNotificationNewCourseSuccessForceOff: Sie werden nicht benachrichtigt, wenn ein neuer Kurs eingetragen wird
AllocationNotificationNewCourseCurrentlyOff: Aktuell würden Sie keine Benachrichtigung erhalten.
AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt werden.
AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein.
AllocationSchoolShort: Institut
Allocation: Zentralanmeldung
@ -2238,6 +2293,13 @@ SchoolName: Name
SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt
SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen
SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozenten gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen.
SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen
SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozenten daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen.
SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung
SchoolExamRequireModeForRegistrationTip: Sollen Dozenten gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen?
SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung
SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
SchoolTitle ssh@SchoolId: Institut „#{ssh}“
@ -2299,6 +2361,11 @@ MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen
MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen.
MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"}
MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen
MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen:
MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen:
MailAllocationNewCourseApplyHere: Sie können sich hier bewerben:
ExamOfficeSubscribedUsers: Benutzer
ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren
@ -2806,4 +2873,7 @@ WorkflowDefinitionWorkflowCount: Workflows
WorkflowDefinitionConcreteInstanceCount num@Int64: #{num} Instanzen
WorkflowDefinitionConcreteWorkflowCount num@Int64: #{num} Workflows
WorkflowDefinitionDeleteQuestion: Wollen Sie die unten aufgeführte Workflow-Definition wirklich löschen?
WorkflowDefinitionDeleted: Workflow-Definition gelöscht
WorkflowDefinitionDeleted: Workflow-Definition gelöscht
ChangelogItemFeature: Feature
ChangelogItemBugfix: Bugfix

View File

@ -787,6 +787,15 @@ FormBehaviour: Behaviour
FormCosmetics: Interface
FormPersonalAppearance: Public data
FormFieldRequiredTip: Required fields
FormAllocationNotifications: Notifications for new central allocation courses
FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications”
AllocNotifyNewCourseDefault: System wide setting
AllocNotifyNewCourseForceOff: No
AllocNotifyNewCourseForceOn: Yes
BtnNotifyNewCourseForceOn: Notify me
BtnNotifyNewCourseForceOff: Do not notify me
PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented.
PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented.
@ -1134,6 +1143,8 @@ NotificationTriggerCourseRegistered: A course administrator has enrolled me in a
NotificationTriggerSubmissionUserCreated: I was added to an exercise sheet submission
NotificationTriggerSubmissionEdited: One of my exercise sheet submissions was changed
NotificationTriggerSubmissionUserDeleted: I was removed from one of my exercise sheet submissions
NotificationTriggerAllocationNewCourse: A new course was added to a central allocation for which I have registered my participation
NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation
NotificationTriggerKindAll: For all users
NotificationTriggerKindCourseParticipant: For course participants
@ -1836,6 +1847,39 @@ ExamFormOccurrences: Occurrences/rooms
ExamFormAutomaticFunctions: Automatic functions
ExamFormCorrection: Correction
ExamFormParts: Exam parts
ExamFormMode: Exam design
ExamModeFormNone: Not specified
ExamModeFormCustom: Custom
ExamModeFormAids: Permitted exam aids
ExamModeFormOnline: Online/Offline
ExamModeFormSynchronicity: Synchronous/Asynchronous
ExamModeFormRequiredEquipment: Required equipment
ExamModeFormRequiredEquipmentIdentificationTip: There will always be a note informing participants that they will need photo identification.
ExamShowAids: Permitted exam aids
ExamShowOnline: Online/Offline
ExamShowSynchronicity: Synchronous/Asynchronous
ExamShowRequiredEquipment: Required equipment
ExamShowRequiredEquipmentNoneSet: Not specified
ExamShowIdentificationRequired: Exam participants need to be able to identify themselves. Therefor please ensure that you have official photo identification („Personalausweis“, passport, residence permit) and your student identification at hand during the exam.
ExamOpenBook: Open book
ExamClosedBook: Closed book
ExamOnline: Online
ExamOffline: Offline
ExamSynchronous: Synchronous
ExamAsynchronous: Asynchronous
ExamRequiredEquipmentNone: Nothing
ExamRequiredEquipmentPen: Pen
ExamRequiredEquipmentPaperPen: Pen & paper
ExamRequiredEquipmentCalculatorPen: Pen & calculator
ExamRequiredEquipmentCalculatorPaperPen: Pen, paper & calculator
ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & microphone
ExamRequiredEquipmentMicrophoneInternet: Microphone
ExamCorrectors: Correctors
ExamCorrectorsTip: Correctors configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
@ -1888,6 +1932,10 @@ ExamFinishedMustBeAfterStart: "Results visible from" must be after "start"
ExamClosedMustBeAfterFinished: "Exam achievements registered" must be after "results visible from"
ExamClosedMustBeAfterStart: "Exam achievements registered" must be after "start"
ExamClosedMustBeAfterEnd: "Exam achievements registered" must be after "end"
ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Start".
ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to".
ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set.
ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged
ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start
ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start
@ -2207,6 +2255,13 @@ ApplicationRatingCommentVisibleTip: Feedback for the applicant
ApplicationRatingCommentInvisibleTip: Currently only a note for course administrators
ApplicationRatingSection: Grading
ApplicationRatingSectionSelfTip: You are authorised to edit the application as well as it's grading.
AllocationNotificationNewCourse: Notifications for new courses
AllocationNotificationNewCourseTip: Do you want to be notified if a new course is added to this central allocation? This overrides the system wide setting under “Settings”.
AllocationNotificationNewCourseSuccessForceOn: You will be notified if a new course is added
AllocationNotificationNewCourseSuccessForceOff: You will not be notified if a new course is added
AllocationNotificationNewCourseCurrentlyOff: Currently you would not receive a notification.
AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified.
AllocationNotificationLoginFirst: To change your notification settings, please log in first.
AllocationSchoolShort: Department
Allocation: Central allocation
@ -2238,6 +2293,13 @@ SchoolName: Name
SchoolLdapOrganisations: Associated LDAP fragments
SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry
SchoolLdapOrganisationMissing: LDAP-fragment is required
SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams
SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time.
SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams
SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days.
SchoolExamRequireModeForRegistration: Exam design required for registration
SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period?
SchoolExamDiscouragedModes: Exam designs to warn against
SchoolUpdated ssh: Successfully edited #{ssh}
SchoolTitle ssh: Department „#{ssh}“
@ -2299,6 +2361,11 @@ MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications
MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated.
MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"}
MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}”
MailAllocationNewCourseTip: The following course was added to the central allocation:
MailAllocationNewCourseEditApplicationsHere: You can modify your application here:
MailAllocationNewCourseApplyHere: You can apply here:
ExamOfficeSubscribedUsers: Users
ExamOfficeSubscribedUsersTip: You may specify multiple matriculations; comma-separated
@ -2775,6 +2842,7 @@ CronMatchNone: Never
SystemExamOffice: Exam office
SystemFaculty: Faculty member
WorkflowInstanceScopeKindGlobal: Global
WorkflowInstanceScopeKindTerm: Per term
WorkflowInstanceScopeKindSchool: Per school
@ -2807,3 +2875,6 @@ WorkflowDefinitionConcreteInstanceCount num: #{num} instances
WorkflowDefinitionConcreteWorkflowCount num: #{num} workflows
WorkflowDefinitionDeleteQuestion: Do you really want to delete the workflow definition listed below?
WorkflowDefinitionDeleted: Successfully deleted workflow definition
ChangelogItemFeature: Feature
ChangelogItemBugfix: Bugfix

View File

@ -50,3 +50,9 @@ AllocationDeregister -- self-inflicted user-deregistrations from an allocated co
course CourseId Maybe
time UTCTime
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
AllocationNotificationSetting
user UserId
allocation AllocationId
isOptOut Bool
UniqueAllocationNotificationSetting user allocation

4
models/changelog.model Normal file
View File

@ -0,0 +1,4 @@
ChangelogItemFirstSeen
item ChangelogItem
firstSeen Day
Primary item

View File

@ -17,6 +17,7 @@ Exam
publicStatistics Bool
gradingMode ExamGradingMode
description Html Maybe
examMode ExamMode
UniqueExam course name
ExamPart
exam ExamId

View File

@ -3,6 +3,10 @@
School json
name (CI Text)
shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId
examMinimumRegisterBeforeStart NominalDiffTime Maybe
examMinimumRegisterDuration NominalDiffTime Maybe
examRequireModeForRegistration Bool default=false
examDiscouragedModes ExamModeDNF
UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "20.4.1",
"version": "20.5.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "20.4.1",
"version": "20.5.0",
"description": "",
"keywords": [],
"author": "",

View File

@ -1,5 +1,5 @@
name: uniworx
version: 20.4.1
version: 20.5.0
dependencies:
- base
@ -25,7 +25,7 @@ dependencies:
- directory
- warp
- data-default
- aeson
- aeson >=1.5
- conduit
- monad-logger
- fast-logger
@ -159,6 +159,7 @@ other-extensions:
- IncoherentInstances
- OverloadedLists
- UndecidableInstances
- ApplicativeDo
default-extensions:
- OverloadedStrings

2
routes
View File

@ -114,7 +114,7 @@
/allocation/ AllocationListR GET !free
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
/ AShowR GET !free
/ AShowR GET POST !free
/register ARegisterR POST !time
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
/users AUsersR GET POST !allocation-admin

View File

@ -1,4 +1,3 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Time.Calendar.Instances
@ -11,8 +10,13 @@ import Data.Time.Calendar
import Data.Universe
import Language.Haskell.TH.Syntax (Lift)
import Type.Reflection
deriving newtype instance Hashable Day
deriving instance Lift Day
instance Hashable Day where
hashWithSalt s (ModifiedJulianDay jDay) = s `hashWithSalt` hash (typeRep @Day) `hashWithSalt` jDay
deriving instance Ord DayOfWeek
instance Universe DayOfWeek where

View File

@ -11,7 +11,7 @@ import Control.Lens.Indexed
import Data.Universe.Instances.Reverse ()
import qualified Data.Map as Map
import qualified Data.Map.Strict as Map
instance Finite a => FoldableWithIndex a ((->) a) where

View File

@ -14,7 +14,10 @@ import Data.Universe.Helpers (interleave)
import Control.Monad (unless)
import Data.List (elemIndex)
import Data.List (elemIndex, nub)
import Control.Lens hiding (universe)
import Data.Generics.Product.Types
-- | Get type var bind name
@ -52,26 +55,37 @@ finiteEnum tName = do
|]
deriveUniverse, deriveFinite :: Name -> DecsQ
deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
deriveFinite tName = fmap concat . sequence $
[ deriveUniverse' [e|concat|] [e|universeF|] tName
, do
DatatypeInfo{..} <- reifyDatatype tName
[d|instance Finite $(foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars)|]
]
deriveUniverse tName = view _1 <$> deriveUniverse' [e|interleave|] [e|universe|] ([t|Universe|] `appT`) tName
deriveFinite tName = do
(decs, iCxt) <- deriveUniverse' [e|concat|] [e|universeF|] ([t|Finite|] `appT`) tName
fmap concat . sequence $
[ pure decs
, do
DatatypeInfo{..} <- reifyDatatype tName
pure <$> instanceD (pure iCxt) (appT [t|Finite|] . foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars) []
]
deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
deriveUniverse' interleaveExp universeExp tName = do
deriveUniverse' :: ExpQ -> ExpQ -> (TypeQ -> TypeQ) -> Name -> Q ([Dec], Cxt)
deriveUniverse' interleaveExp universeExp mkCxt tName = do
DatatypeInfo{..} <- reifyDatatype tName
let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars
consUniverse ConstructorInfo{..} = do
let consUniverse ConstructorInfo{..} = do
unless (null constructorVars) $
fail "Constructors with variables no supported"
foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
typ = foldl (\t bndr -> t `appT` varT (getTVBName bndr)) (conT tName) datatypeVars
iCxt = map (mkCxt . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map getTVBName datatypeVars
usesVar ConstructorInfo{..} n
| n `elem` map getTVBName constructorVars = False
| otherwise = any (elemOf types n) constructorFields
fieldTypes = nub $ concatMap constructorFields datatypeCons
iCxt' <- cxt iCxt
(, iCxt') . pure <$> instanceD (pure iCxt') [t|Universe $(typ)|]
[ funD 'universe
[ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
]

View File

@ -10,3 +10,6 @@ instance ToContent Void where
toContent = absurd
instance ToTypedContent Void where
toTypedContent = absurd
instance RenderMessage site Void where
renderMessage _ _ = absurd

View File

@ -47,10 +47,6 @@ import Data.Text.Lens (packed)
import Data.List ((!!))
appLanguages :: NonEmpty Lang
appLanguages = "de-de-formal" :| ["en-eu"]
pluralDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ Singular
@ -225,6 +221,11 @@ embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
embedRenderMessage ''UniWorX ''FavouriteReason id
embedRenderMessage ''UniWorX ''Sex id
embedRenderMessage ''UniWorX ''ExamGradingMode id
embedRenderMessage ''UniWorX ''ExamAidsPreset id
embedRenderMessage ''UniWorX ''ExamOnlinePreset id
embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
embedRenderMessage ''UniWorX ''ChangelogItemKind id
embedRenderMessage ''UniWorX ''WorkflowInstanceScope' $ ("WorkflowInstanceScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowInstanceScope' to have '") . stripSuffix "'"
embedRenderMessage ''UniWorX ''AuthenticationMode id

View File

@ -446,7 +446,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
guard $ userSystemMessageShown <= Just systemMessageLastChanged
guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
(_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
(_, smTrans) <- MaybeT $ getSystemMessage smId
let
(summary, content) = case smTrans of
Nothing -> (systemMessageSummary, systemMessageContent)

View File

@ -7,7 +7,6 @@ import Import.NoFoundation hiding (yesodMiddleware)
import Foundation.Type
import Foundation.Routes
import Foundation.I18n
import Foundation.Authorization
import Utils.Metrics

View File

@ -19,10 +19,11 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as C
data AllocationApplicationButton = BtnAllocationApply
| BtnAllocationApplicationEdit
| BtnAllocationApplicationRetract
| BtnAllocationApplicationRate
data AllocationApplicationButton
= BtnAllocationApply
| BtnAllocationApplicationEdit
| BtnAllocationApplicationRetract
| BtnAllocationApplicationRate
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AllocationApplicationButton
instance Finite AllocationApplicationButton
@ -32,6 +33,11 @@ embedRenderMessage ''UniWorX ''AllocationApplicationButton id
makePrisms ''AllocationApplicationButton
instance Button UniWorX AllocationApplicationButton where
btnLabel BtnAllocationApply = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|]
btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|]
btnLabel BtnAllocationApplicationEdit = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|]
btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate
btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger]
btnClasses _ = [BCIsButton, BCPrimary]

View File

@ -36,6 +36,19 @@ nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''AllocationRegisterButton id
instance Button UniWorX AllocationRegisterButton where
btnLabel BtnAllocationRegister
= [whamlet|
$newline never
#{iconAllocationRegister} \
_{BtnAllocationRegister}
|]
btnLabel BtnAllocationRegistrationEdit
= [whamlet|
$newline never
#{iconAllocationRegistrationEdit} \
_{BtnAllocationRegistrationEdit}
|]
btnClasses _ = [BCIsButton, BCPrimary]
postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void

View File

@ -1,5 +1,5 @@
module Handler.Allocation.Show
( getAShowR
( getAShowR, postAShowR
) where
import Import
@ -7,6 +7,7 @@ import Import
import Utils.Course
import Handler.Utils
import Handler.Utils.Allocation (allocationNotifyNewCourses)
import Handler.Allocation.Register
import Handler.Allocation.Application
@ -15,8 +16,34 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAShowR tid ssh ash = do
data NotifyNewCourseButton
= BtnNotifyNewCourseForceOn
| BtnNotifyNewCourseForceOff
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
embedRenderMessage ''UniWorX ''NotifyNewCourseButton id
nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2
instance Button UniWorX NotifyNewCourseButton where
btnLabel BtnNotifyNewCourseForceOn
= [whamlet|
$newline never
#{iconNotification} \
_{BtnNotifyNewCourseForceOn}
|]
btnLabel BtnNotifyNewCourseForceOff
= [whamlet|
$newline never
#{iconNoNotification} \
_{BtnNotifyNewCourseForceOff}
|]
btnClasses _ = [BCIsButton]
getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAShowR = postAShowR
postAShowR tid ssh ash = do
muid <- maybeAuthId
now <- liftIO getCurrentTime
ata <- getSessionActiveAuthTags
@ -33,7 +60,7 @@ getAShowR tid ssh ash = do
resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool
resultCourseVisible = _5 . _Value
(Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
(Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration, wouldNotifyNewCourse) <- runDB $ do
alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
school <- getJust allocationSchool
@ -58,7 +85,9 @@ getAShowR tid ssh ash = do
isAnyLecturer <- hasWriteAccessTo CourseNewR
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
MsgRenderer mr <- getMsgRenderer
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
@ -67,7 +96,7 @@ getAShowR tid ssh ash = do
-- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
-- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
(registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
(registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
let
registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
registerForm' = wrapForm' registerBtn registerForm FormSettings
@ -79,6 +108,35 @@ getAShowR tid ssh ash = do
, formAnchor = Nothing :: Maybe Text
}
((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if
| wouldNotifyNewCourse
-> [BtnNotifyNewCourseForceOff]
| otherwise
-> [BtnNotifyNewCourseForceOn]
let
allocationNotificationIdent = "allocation-notification" :: Text
notificationForm' = wrapForm notificationForm FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR
, formEncoding = notificationEnctype
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Just allocationNotificationIdent
}
whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do
let allocationNotificationSettingIsOptOut = case notificationBtn of
BtnNotifyNewCourseForceOn -> False
BtnNotifyNewCourseForceOff -> True
runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting
{ allocationNotificationSettingUser = uid
, allocationNotificationSettingAllocation = aId
, allocationNotificationSettingIsOptOut
}
[ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ]
addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut
redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent
siteLayoutMsg title $ do
setTitleI shortTitle

View File

@ -563,18 +563,18 @@ courseEditHandler miButtonAction mbCourseForm = do
, formEncoding = formEnctype
}
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime
Course{} <- getJust cid
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
userAdmin <- fromMaybe False <$> for prevAllocation (\(Entity _ Allocation{..}) -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
doEdit <- if
| userAdmin
-> return True
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
| Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation
, NTop allocationStaffRegisterTo <= NTop (Just now)
-> let anyChanges
| Just AllocationCourseForm{..} <- cfAllocation
@ -590,7 +590,7 @@ upsertAllocationCourse cid cfAllocation = do
when doEdit $
case cfAllocation of
Just AllocationCourseForm{..} ->
Just AllocationCourseForm{..} -> do
void $ upsert AllocationCourse
{ allocationCourseAllocation = acfAllocation
, allocationCourseCourse = cid
@ -600,6 +600,9 @@ upsertAllocationCourse cid cfAllocation = do
, AllocationCourseCourse =. cid
, AllocationCourseMinCapacity =. acfMinCapacity
]
when (Just acfAllocation /= fmap entityKey prevAllocation) $
queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
Nothing
| Just (Entity prevId _) <- prevAllocationCourse
-> delete prevId

View File

@ -25,7 +25,7 @@ postEEditR tid ssh csh examn = do
return (cid, exam, template)
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template
formResult editExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do
, examPublicStatistics = efPublicStatistics
, examGradingMode = efGradingMode
, examDescription = efDescription
, examExamMode = efExamMode
}
when (is _Nothing insertRes) $ do

View File

@ -12,12 +12,14 @@ import Handler.Exam.CorrectorInvite ()
import Handler.Utils
import Handler.Utils.Invitations
import Handler.Utils.Exam (evalExamModeDNF)
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Control.Monad.State.Class as State
import Text.Blaze.Html.Renderer.String (renderHtml)
@ -40,6 +42,7 @@ data ExamForm = ExamForm
, efGradingRule :: Maybe ExamGradingRule
, efBonusRule :: Maybe ExamBonusRule
, efOccurrenceRule :: ExamOccurrenceRule
, efExamMode :: ExamMode
, efCorrectors :: Set (Either UserEmail UserId)
, efExamParts :: Set ExamPartForm
}
@ -117,6 +120,8 @@ examForm template html = do
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormMode
<*> examModeForm (efExamMode <$> template)
<* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts
@ -302,6 +307,7 @@ examFormTemplate (Entity eId Exam{..}) = do
Entity _ ExamCorrector{..} <- correctors
return examCorrectorUser
]
, efExamMode = examExamMode
}
examTemplate :: CourseId -> DB (Maybe ExamForm)
@ -347,11 +353,12 @@ examTemplate cid = runMaybeT $ do
, efOccurrences = Set.empty
, efExamParts = Set.empty
, efCorrectors = Set.empty
, efExamMode = examExamMode oldExam
}
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
validateExam = do
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m ()
validateExam cId oldExam = do
ExamForm{..} <- State.get
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
@ -377,3 +384,50 @@ validateExam = do
]
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseId E.==. E.val cId
return school
whenIsJust mSchool $ \(Entity _ School{..}) -> do
whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
let doValidation
| Just Exam{..} <- oldExam
, not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
= warnValidation
| otherwise
= guardValidation
doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay)
. fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
let doValidation
| Just Exam{..} <- oldExam
, not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
= warnValidation
| otherwise
= guardValidation
doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay)
. fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
when schoolExamRequireModeForRegistration $ do
let doValidation
| Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam
, or [ is _Nothing examAids
, is _Nothing examOnline
, is _Nothing examSynchronicity
, is _Nothing examRequiredEquipment
]
, is _Just examRegisterFrom
= warnValidation
| otherwise
= guardValidation
let ExamMode{..} = efExamMode
doValidation MsgExamModeRequiredForRegistration
$ is _Nothing efRegisterFrom
|| and [ is _Just examAids
, is _Just examOnline
, is _Just examSynchronicity
, is _Just examRequiredEquipment
]
warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode

View File

@ -24,7 +24,7 @@ postCExamNewR tid ssh csh = do
template <- examTemplate cid
return (cid, template)
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
formResult newExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
@ -49,6 +49,7 @@ postCExamNewR tid ssh csh = do
, examGradingMode = efGradingMode
, examPublicStatistics = efPublicStatistics
, examDescription = efDescription
, examExamMode = efExamMode
}
whenIsJust insertRes $ \examid -> do
insertMany_

View File

@ -26,8 +26,9 @@ getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime
mUid <- maybeAuthId
(Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
(Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
school <- getJust examCourse >>= belongsToJust courseSchool
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -82,7 +83,7 @@ getEShowR tid ssh csh examn = do
lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
let occurrenceNamesShown = lecturerInfoShown
partNumbersShown = lecturerInfoShown
@ -174,6 +175,11 @@ getEShowR tid ssh csh examn = do
let heading = prependCourseTitle tid ssh csh $ CI.original examName
notificationDiscouragedExamMode <- runMaybeT $ do
guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode
guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR
return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged
siteLayoutMsg heading $ do
setTitleI heading
let
@ -190,4 +196,6 @@ getEShowR tid ssh csh examn = do
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
notificationPersonalIdentification = notification NotificationBroad =<< messageIconI Info IconPersonalIdentification MsgExamShowIdentificationRequired
$(widgetFile "exam-show")

View File

@ -5,7 +5,9 @@ import Handler.Utils
import Handler.Info.TH
import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
@ -34,17 +36,26 @@ getLegalR =
-- | Allgemeine Informationen
getInfoR :: Handler Html
getInfoR = -- do
getInfoR = do
changelogEntries' <- runDB $ selectList [] []
let changelogEntries = Map.fromListWith Set.union
[ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)
| Entity _ ChangelogItemFirstSeen{..} <- changelogEntries'
]
siteLayoutMsg MsgInfoHeading $ do
setTitleI MsgInfoHeading
let features = $(i18nWidgetFile "featureList")
changeLog = $(i18nWidgetFile "changelog")
changeLog = $(widgetFile "changelog")
knownBugs = $(i18nWidgetFile "knownBugs")
implementation = $(i18nWidgetFile "implementation")
gitInfo :: Text
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
$(widgetFile "versionHistory")
where
changelogItems = $(i18nWidgetFiles "changelog")
getInfoLecturerR :: Handler Html
getInfoLecturerR =
@ -67,9 +78,9 @@ getInfoLecturerR =
-- new feature with given introduction date
newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
newFeat year month day = do
newFeat y m d = do
currentTime <- liftIO getCurrentTime
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0
if currentTime > expiryTime
then mempty
else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]
@ -90,7 +101,7 @@ getGlossaryR =
msgMap = $(glossaryTerms "glossary")
mkFaqItems "faq"
mkI18nWidgetEnum "FAQ" "faq"
mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX

View File

@ -1,10 +1,8 @@
module Handler.Info.TH
( glossaryTerms
, mkFaqItems
) where
import Import
import Handler.Utils.I18n
import Language.Haskell.TH
@ -22,52 +20,3 @@ glossaryTerms basename = do
where
unPathPiece :: Text -> String
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
mkFaqItems :: FilePath -> DecsQ
mkFaqItems basename = do
itemsAvailable <- i18nWidgetFilesAvailable' basename
let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable
sequence
[ dataD (cxt []) dataName [] Nothing
[ normalC (mkName conName) []
| (_, conName) <- Map.toAscList items
]
[ derivClause (Just StockStrategy)
[ conT ''Eq
, conT ''Ord
, conT ''Read
, conT ''Show
, conT ''Enum
, conT ''Bounded
, conT ''Generic
, conT ''Typeable
]
, derivClause (Just AnyclassStrategy)
[ conT ''Universe
, conT ''Finite
]
]
, instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
[ funD 'toPathPiece
[ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
| (int, con) <- Map.toList items
]
, funD 'fromPathPiece
[ clause [varP $ mkName "t"]
( guardedB
[ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
| (int, con) <- Map.toList items
]) []
, clause [wildP] (normalB [e|Nothing|]) []
]
]
, sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|]
, funD (mkName "faqItemMap")
[ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
]
]
where
unPathPiece :: Text -> String
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
dataName = mkName "FAQItem"

View File

@ -69,7 +69,7 @@ newsSystemMessages = do
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
transPipe lift (selectKeys [] [])
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
.| C.mapMaybeM checkHidden
.| C.iterM (\(smId, _, _, _) -> tellShown smId)

View File

@ -45,6 +45,7 @@ data SettingsForm = SettingsForm
, stgShowSex :: Bool
, stgSchools :: Set SchoolId
, stgNotificationSettings :: NotificationSettings
, stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool)
}
makeLenses_ ''SettingsForm
@ -79,6 +80,15 @@ instance RenderMessage UniWorX NotificationTriggerKind where
where
mr = renderMessage f ls
data AllocationNotificationState
= AllocNotifyNewCourseDefault
| AllocNotifyNewCourseForceOff
| AllocNotifyNewCourseForceOn
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
embedRenderMessage ''UniWorX ''AllocationNotificationState id
nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
@ -108,6 +118,7 @@ makeSettingForm template html = do
<* aformSection MsgFormNotifications
<*> schoolsForm (stgSchools <$> template)
<*> notificationForm (stgNotificationSettings <$> template)
<*> allocationNotificationForm (stgAllocationNotificationSettings <$> template)
return (result, widget) -- no validation required here
where
themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]
@ -196,13 +207,17 @@ notificationForm template = wFormToAForm $ do
& fmap (!)
let
ntfs nt = fslI nt & case nt of
NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip
_other -> id
nsForm nt
| maybe False ntHidden $ ntSection nt
= pure $ notificationAllowed def nt
| nt `elem` forcedTriggers
= aforced checkBoxField (fslI nt) (notificationAllowed def nt)
= aforced checkBoxField (ntfs nt) (notificationAllowed def nt)
| otherwise
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
= apopt checkBoxField (ntfs nt) (flip notificationAllowed nt <$> template)
ntSection = \case
NTSubmissionRatedGraded -> Just NTKCourseParticipant
@ -229,6 +244,7 @@ notificationForm template = wFormToAForm $ do
NTAllocationOutdatedRatings -> Just NTKAllocationStaff
NTAllocationUnratedApplications -> Just NTKAllocationStaff
NTAllocationResults -> Just NTKAllocationParticipant
NTAllocationNewCourse -> Just NTKAllocationParticipant
NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice
NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice
NTCourseRegistered -> Just NTKAll
@ -238,6 +254,62 @@ notificationForm template = wFormToAForm $ do
aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool))
getAllocationNotifications uid
= fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any)))
[ getBySettings
, getByApplications
, getByAllocationUser
]
where
getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] []
where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation
, Just $ not allocationNotificationSettingIsOptOut
)
| Entity _ AllocationNotificationSetting{..} <- settings
]
getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] []
where toMap applications = Map.fromList [ (alloc, Nothing)
| Entity _ CourseApplication{..} <- applications
, alloc <- hoistMaybe courseApplicationAllocation
]
getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] []
where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing)
| Entity _ AllocationUser{..} <- allocsUser
]
setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m ()
setAllocationNotifications allocationNotificationSettingUser allocs = do
deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ]
void . insertMany $ do
(allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs
allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt
return AllocationNotificationSetting{..}
allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<)
where
allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do
let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState
_AllocNotify = iso toNotify fromNotify
where fromNotify = \case
AllocNotifyNewCourseDefault -> Nothing
AllocNotifyNewCourseForceOn -> Just True
AllocNotifyNewCourseForceOff -> Just False
toNotify = \case
Nothing -> AllocNotifyNewCourseDefault
Just True -> AllocNotifyNewCourseForceOn
Just False -> AllocNotifyNewCourseForceOff
Allocation{..} <- liftHandler . runDB $ getJust allocId
MsgRenderer mr <- getMsgRenderer
let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|]
cID <- encrypt allocId :: _ CryptoUUIDAllocation
fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify)
where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False
validateSettings :: User -> FormValidator SettingsForm Handler ()
validateSettings User{..} = do
@ -276,6 +348,7 @@ postProfileR = do
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
return $ school E.^. SchoolId
allocs <- runDB $ getAllocationNotifications uid
let settingsTemplate = Just SettingsForm
{ stgDisplayName = userDisplayName
, stgDisplayEmail = userDisplayEmail
@ -290,6 +363,7 @@ postProfileR = do
, stgNotificationSettings = userNotificationSettings
, stgWarningDays = userWarningDays
, stgShowSex = userShowSex
, stgAllocationNotificationSettings = allocs
}
((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
@ -308,6 +382,7 @@ postProfileR = do
, UserNotificationSettings =. stgNotificationSettings
, UserShowSex =. stgShowSex
] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
setAllocationNotifications uid stgAllocationNotificationSettings
updateFavourites Nothing
when (stgDisplayEmail /= userDisplayEmail) $ do
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
@ -777,9 +852,13 @@ getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
getUserNotificationR = postUserNotificationR
postUserNotificationR cID = do
uid <- decrypt cID
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
(User{userNotificationSettings, userDisplayName}, allocs) <- runDB $ (,)
<$> get404 uid
<*> getAllocationNotifications uid
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,)
<$> notificationForm (Just userNotificationSettings)
<*> allocationNotificationForm (Just allocs)
mBearer <- askBearer
isModal <- hasCustomHeader HeaderIsModal
let formWidget = wrapForm nsInnerWdgt def
@ -788,8 +867,10 @@ postUserNotificationR cID = do
, formAttrs = [ asyncSubmitAttr | isModal ]
}
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do
lift . runDB $ do
update uid [ UserNotificationSettings =. ns ]
setAllocationNotifications uid ans
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do

View File

@ -62,6 +62,10 @@ data SchoolForm = SchoolForm
{ sfShorthand :: CI Text
, sfName :: CI Text
, sfOrgUnits :: Set (CI Text)
, sfExamMinimumRegisterBeforeStart
, sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
, sfExamRequireModeForRegistration :: Bool
, sfExamDiscouragedModes :: ExamModeDNF
}
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
@ -69,6 +73,10 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
<*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
<*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
where
ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
@ -82,6 +90,10 @@ schoolToForm ssh = do
{ sfShorthand = schoolShorthand
, sfName = schoolName
, sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
, sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart
, sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
, sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
, sfExamDiscouragedModes = schoolExamDiscouragedModes
}
@ -94,7 +106,13 @@ postSchoolEditR ssh = do
formResult sfResult $ \SchoolForm{..} -> do
runDB $ do
update ssh [ SchoolName =. sfName ]
update ssh
[ SchoolName =. sfName
, SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
, SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
, SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
, SchoolExamDiscouragedModes =. sfExamDiscouragedModes
]
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
void $ upsert SchoolLdap
{ schoolLdapSchool = Just ssh
@ -131,6 +149,10 @@ postSchoolNewR = do
didInsert <- is _Just <$> insertUnique School
{ schoolShorthand = sfShorthand
, schoolName = sfName
, schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart
, schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
, schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
, schoolExamDiscouragedModes = sfExamDiscouragedModes
}
when didInsert $ do
insert_ UserFunction

View File

@ -25,7 +25,7 @@ getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
getMessageR = postMessageR
postMessageR cID = do
smId <- decrypt cID
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId
let (summary, content) = case translation of
Nothing -> (systemMessageSummary, systemMessageContent)
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
@ -185,7 +185,7 @@ postMessageListR = do
in cell . toWidget $ fromMaybe content summary
]
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
smT <- (>>= view _2) <$> getSystemMessage smId
return DBRow
{ dbrOutput = (smE, smT)
, ..

View File

@ -1,5 +1,5 @@
module Handler.Utils.Allocation
( allocationStarted
( allocationStarted, allocationNotifyNewCourses
, ordinalPriorities
, sinkAllocationPriorities
, MatchingLogRun(..)
@ -70,6 +70,25 @@ allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from
E.where_ $ allocationMatching E.^. AllocationMatchingAllocation E.==. E.val allocId
return . E.min_ $ allocationMatching E.^. AllocationMatchingTime
allocationNotifyNewCourses :: E.SqlExpr (E.Value AllocationId)
-> E.SqlExpr (E.Value UserId)
-> E.SqlExpr (E.Value Bool)
allocationNotifyNewCourses allocId uid = ( hasOverride True E.||. hasApplication E.||. isParticipant )
E.&&. E.not_ (hasOverride False)
where
hasOverride overrideVal = E.exists . E.from $ \allocationNotificationSetting ->
E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. uid
E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. allocId
E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut E.==. E.val (not overrideVal)
hasApplication = E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just allocId
E.&&. application E.^. CourseApplicationUser E.==. uid
isParticipant = E.exists . E.from $ \allocationUser ->
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. allocId
E.&&. allocationUser E.^. AllocationUserUser E.==. uid
ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ)

View File

@ -213,9 +213,9 @@ formatDiffDays t
setYear :: Integer -> Day -> Day
setYear year date = fromGregorian year month day
setYear year date = fromGregorian year m d
where
(_,month,day) = toGregorian date
(_,m,d) = toGregorian date
addOneWeek :: UTCTime -> UTCTime
addOneWeek = addWeeks 1
@ -295,7 +295,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
formatGregorianW :: Integer -> Int -> Int -> Widget
formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
instance Csv.ToField ZonedTime where
toField = Csv.toField . iso8601Show

View File

@ -11,6 +11,8 @@ module Handler.Utils.Exam
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
, examAutoOccurrence
, deregisterExamUsersCount, deregisterExamUsers
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
, evalExamModeDNF
) where
import Import
@ -50,6 +52,8 @@ import qualified Data.Char as Char
import qualified Data.RFC5051 as RFC5051
import Handler.Utils.I18n
fetchExamAux :: ( SqlBackendCanRead backend
, E.SqlSelect b a
@ -641,3 +645,38 @@ deregisterExamUsersCount eId uids = do
deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids
examAidsPresetWidget :: ExamAidsPreset -> Widget
examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids")
examOnlinePresetWidget :: ExamOnlinePreset -> Widget
examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online")
examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget
examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity")
examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget
examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment")
evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool
evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
= dnfTerms
& map (Set.toList . toNullable) . Set.toList
& map ( maybe True (ofoldr1 (&&))
. fromNullable
. map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl)
)
& maybe False (ofoldr1 (||)) . fromNullable
where
evalPred :: ExamModePredicate -> Bool
evalPred = \case
ExamModePredAids p
-> examAids == Just (ExamAidsPreset p)
ExamModePredOnline p
-> examOnline == Just (ExamOnlinePreset p)
ExamModePredSynchronicity p
-> examSynchronicity == Just (ExamSynchronicityPreset p)
ExamModePredRequiredEquipment p
-> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)

View File

@ -19,6 +19,8 @@ import Handler.Utils.I18n
import Handler.Utils.Files
import Handler.Utils.Exam
import Import
import Data.Char ( chr, ord, isDigit )
import qualified Data.Char as Char
@ -1379,35 +1381,28 @@ boolField mkNone = radioGroupField mkNone $ do
sectionedFuncForm :: forall k v m sec.
( Finite k, Ord k
sectionedFuncForm :: forall f k v m sec.
( TraversableWithIndex k f
, MonadHandler m
, HandlerSite m ~ UniWorX
, RenderMessage UniWorX sec
, Ord sec
)
=> (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
=> (k -> Maybe sec) -> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
where
funcForm' :: AForm m (k -> v)
funcForm' = Set.fromList universeF
& foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
& fmap (Map.fromSet mkForm)
& fmap sequenceA
& Map.foldrWithKey accSections (pure Map.empty)
& fmap (!)
accSections mSection optsForm acc = wFormToAForm $ do
(res, fs) <- wFormFields $ aFormToWForm optsForm
if
| not $ null fs
, Just section <- mSection
-> wformSection section
| otherwise
-> return ()
lift $ tell fs
aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
funcForm' :: AForm m (f v)
funcForm' = wFormToAForm $ do
(res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form
-> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form
funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
iforM_ fs $ \mSection secfs -> unless (null secfs) $ do
traverse_ wformSection mSection
lift $ tell secfs
return $ sequenceA res
funcFieldView :: (FormResult (f v), Widget) -> MForm m (FormResult (f v), [FieldView UniWorX])
funcFieldView (res, formView) = do
mr <- getMessageRender
fvId <- maybe newIdent return fsId
@ -1419,16 +1414,15 @@ sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} is
| otherwise = Nothing
fvInput = $(widgetFile "widgets/fields/funcField")
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
funcForm :: forall k v m.
( Finite k, Ord k
funcForm :: forall f k v m.
( TraversableWithIndex k f
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
=> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void)
@ -1996,3 +1990,97 @@ courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (
userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User))
-> Handler (OptionList UserId)
userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName
data CustomPresetFormOption p
= CPFONone
| CPFOPreset p
| CPFOCustom
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveFinite ''CustomPresetFormOption
derivePathPiece ''CustomPresetFormOption (camelToPathPiece' 1) "--"
customPresetForm :: forall a custom preset msg.
( Finite preset, Ord preset, PathPiece preset
, RenderMessage UniWorX msg
)
=> Iso' a (Either custom preset)
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for custom option
-> (preset -> (msg, Maybe Widget))
-> (Maybe custom -> AForm Handler custom)
-> FieldSettings UniWorX
-> Maybe (Maybe a)
-> AForm Handler (Maybe a)
customPresetForm cpL noneOption customOption toOption customForm fs mPrev
= explainedMultiActionA actionMap options fs mPrev'
where
mPrev' = flip fmap mPrev $ preview (_Just . cpL) >>> \case
Nothing -> CPFONone
Just (Left _) -> CPFOCustom
Just (Right p) -> CPFOPreset p
options = explainOptionList options' $ hoistMaybe . optionToWidget
where options' = do
MsgRenderer mr <- getMsgRenderer
let olReadExternal t = do
opt <- fromPathPiece t
case opt of
CPFONone -> opt <$ hoistMaybe noneOption
CPFOCustom -> opt <$ hoistMaybe customOption
CPFOPreset _ -> pure opt
olOptions = do
optionInternalValue <- universeF
optionDisplay <- case optionInternalValue of
CPFONone -> views _1 mr <$> hoistMaybe noneOption
CPFOCustom -> views _1 mr <$> hoistMaybe customOption
CPFOPreset p -> return . views _1 mr $ toOption p
let optionExternalValue = toPathPiece optionInternalValue
return Option{..}
return OptionList{..}
optionToWidget = \case
CPFONone -> noneOption ^? _Just . _2 . _Just
CPFOCustom -> customOption ^? _Just . _2 . _Just
CPFOPreset p -> toOption p ^. _2
actionMap :: Map (CustomPresetFormOption preset) (AForm Handler (Maybe a))
actionMap = Map.fromList $ do
opt <- universeF
return . (opt, ) $ case opt of
CPFONone -> pure Nothing
CPFOPreset p -> pure . Just $ cpL # Right p
CPFOCustom -> reviews cpL Just . Left <$> customForm (mPrev ^? _Just . _Just . cpL . _Left)
examModeForm :: Maybe ExamMode -> AForm Handler ExamMode
examModeForm mPrev = examMode
<$> customPresetForm examSynchronicityEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examSynchronicityPresetWidget) (apreq htmlField (fslI MsgExamModeFormSynchronicity)) (fslI MsgExamModeFormSynchronicity) (examSynchronicity <$> mPrev)
<*> customPresetForm examOnlineEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examOnlinePresetWidget) (apreq htmlField (fslI MsgExamModeFormOnline)) (fslI MsgExamModeFormOnline) (examOnline <$> mPrev)
<*> customPresetForm examAidsEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examAidsPresetWidget) (apreq htmlField (fslI MsgExamModeFormAids)) (fslI MsgExamModeFormAids) (examAids <$> mPrev)
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
where
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset)
examAidsEither = iso examAidsToEither examAidsFromEither
where examAidsToEither (ExamAidsPreset p) = Right p
examAidsToEither (ExamAidsCustom c) = Left c
examAidsFromEither (Right p) = ExamAidsPreset p
examAidsFromEither (Left c) = ExamAidsCustom c
examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset)
examOnlineEither = iso examOnlineToEither examOnlineFromEither
where examOnlineToEither (ExamOnlinePreset p) = Right p
examOnlineToEither (ExamOnlineCustom c) = Left c
examOnlineFromEither (Right p) = ExamOnlinePreset p
examOnlineFromEither (Left c) = ExamOnlineCustom c
examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset)
examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
examSynchronicityToEither (ExamSynchronicityCustom c) = Left c
examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
examSynchronicityFromEither (Left c) = ExamSynchronicityCustom c
examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset)
examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c
examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c

View File

@ -1,25 +1,23 @@
module Handler.Utils.I18n
( i18nWidgetFile
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
, i18nWidgetFiles
, i18nMessage
, module Utils.I18n
) where
import Import.NoFoundation
import Foundation.Type
import Foundation.I18n
import Utils.I18n
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import System.Directory (listDirectory)
@ -52,20 +50,6 @@ i18nWidgetFile basename = do
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do
let i18nDirectory = "templates" </> "i18n" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
fileKinds :: Map Text [Text]
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
iforM fileKinds $ \kind -> maybe (fail $ "" <> i18nDirectory <> " has no translations for " <> unpack kind <> "") return . NonEmpty.nonEmpty
i18nWidgetFilesAvailable :: FilePath -> Q Exp
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
i18nWidgetFiles :: FilePath -> Q Exp
i18nWidgetFiles basename = do
availableTranslations' <- i18nWidgetFilesAvailable' basename

View File

@ -66,7 +66,7 @@ import Data.List as Import (elemIndex)
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Min(..), Max(..))
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..))
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..), Ap(..))
import Data.Binary as Import (Binary)
import Data.Binary.Instances as Import ()

View File

@ -14,6 +14,7 @@ import qualified Data.Set as Set
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.Allocation (allocationNotifyNewCourses)
import qualified Data.Conduit.Combinators as C
@ -22,21 +23,24 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
dispatchJobQueueNotification jNotification = JobHandlerAtomic $
runConduit $ yield jNotification
.| transPipe (hoist lift) determineNotificationCandidates
.| C.filterM (\(notification', Entity _ User{userNotificationSettings}) -> notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', Entity uid _) -> JobSendNotification uid notification')
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings}) -> or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
.| sinkDBJobs
determineNotificationCandidates :: ConduitT Notification (Notification, Entity User) DB ()
determineNotificationCandidates :: ConduitT Notification (Notification, Bool, Entity User) DB ()
determineNotificationCandidates = awaitForever $ \notif -> do
let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Entity User) DB ()
withNotif c = toProducer c .| C.map (notif, )
let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
withNotif c = toProducer c .| C.map (notif, False, )
withNotifOverride :: ConduitT () (E.Value Bool, Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
withNotifOverride c = toProducer c .| C.map (\(E.Value override, user) -> (notif, override, user))
-- | Assumes that conduit produces output sorted by `UserId`
separateTargets :: Ord target
=> (Set target -> Notification)
-> ConduitT () (Entity User, E.Value target) DB ()
-> ConduitT Notification (Notification, Entity User) DB ()
-> ConduitT Notification (Notification, Bool, Entity User) DB ()
separateTargets mkNotif' c = toProducer c .| go Nothing Set.empty
where go Nothing _ = do
next <- await
@ -46,10 +50,10 @@ determineNotificationCandidates = awaitForever $ \notif -> do
go (Just uent) ts = do
next <- await
case next of
Nothing -> yield (mkNotif' ts, uent)
Nothing -> yield (mkNotif' ts, False, uent)
Just next'@(uent', E.Value t)
| ((==) `on` entityKey) uent uent' -> go (Just uent) $ Set.insert t ts
| otherwise -> yield (mkNotif' ts, uent) >> leftover next' >> go Nothing Set.empty
| otherwise -> yield (mkNotif' ts, False, uent) >> leftover next' >> go Nothing Set.empty
case notif of
NotificationSubmissionRated{..}
@ -281,6 +285,21 @@ determineNotificationCandidates = awaitForever $ \notif -> do
-> withNotif . yieldMMany $ getEntity nUser
NotificationSubmissionUserDeleted{..}
-> withNotif . yieldMMany $ getEntity nUser
NotificationAllocationNewCourse{..}
-> withNotifOverride . E.selectSource . E.from $ \user -> do
let hasOverride = E.exists . E.from $ \allocationNotificationSetting ->
E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. user E.^. UserId
E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. E.val nAllocation
E.&&. E.not_ (allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut)
E.where_ . allocationNotifyNewCourses (E.val nAllocation) $ user E.^. UserId
E.where_ . E.not_ . E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation
E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
E.&&. application E.^. CourseApplicationCourse E.==. E.val nCourse
return (hasOverride, user)
classifyNotification :: Notification -> DB NotificationTrigger
@ -315,3 +334,4 @@ classifyNotification NotificationCourseRegistered{} = return NTCou
classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited
classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated
classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted
classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse

View File

@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.Allocation
, dispatchNotificationAllocationAllocation
, dispatchNotificationAllocationUnratedApplications
, dispatchNotificationAllocationResults
, dispatchNotificationAllocationNewCourse
) where
import Import
@ -183,3 +184,24 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet")
dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler ()
dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do
(Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,)
<$> getJust nAllocation
<*> getJust nCourse
<*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName
editNotifications <- mkEditNotifications jRecipient
cID <- encrypt nCourse
mayApply <- orM
[ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True
, is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True
]
allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet")

View File

@ -43,83 +43,86 @@ import System.Clock (getTime, Clock(Monotonic), TimeSpec)
import GHC.Conc (unsafeIOToSTM)
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jSubject :: Maybe Text
, jHelpRequest :: Maybe Html
, jReferer :: Maybe Text
, jError :: Maybe ErrorResponse
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
| JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
, jAllRecipientAddresses :: Set Address
, jCourse :: CourseId
, jSender :: UserId
, jMailObjectUUID :: UUID
, jSubject :: Maybe Text
, jMailContent :: Html
}
| JobInvitation { jInviter :: Maybe UserId
, jInvitee :: UserEmail
, jInvitationUrl :: Text
, jInvitationSubject :: Text
, jInvitationExplanation :: Html
data Job
= JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jSubject :: Maybe Text
, jHelpRequest :: Maybe Html
, jReferer :: Maybe Text
, jError :: Maybe ErrorResponse
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
| JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
, jAllRecipientAddresses :: Set Address
, jCourse :: CourseId
, jSender :: UserId
, jMailObjectUUID :: UUID
, jSubject :: Maybe Text
, jMailContent :: Html
}
| JobInvitation { jInviter :: Maybe UserId
, jInvitee :: UserEmail
, jInvitationUrl :: Text
, jInvitationSubject :: Text
, jInvitationExplanation :: Html
}
| JobSendPasswordReset { jRecipient :: UserId
}
| JobSendPasswordReset { jRecipient :: UserId
}
| JobTruncateTransactionLog
| JobPruneInvitations
| JobDeleteTransactionLogIPs
| JobSynchroniseLdap { jNumIterations
| JobTruncateTransactionLog
| JobPruneInvitations
| JobDeleteTransactionLogIPs
| JobSynchroniseLdap { jNumIterations
, jEpoch
, jIteration :: Natural
}
| JobSynchroniseLdapUser { jUser :: UserId
}
| JobChangeUserDisplayEmail { jUser :: UserId
, jDisplayEmail :: UserEmail
}
| JobPruneSessionFiles
| JobPruneUnreferencedFiles { jNumIterations
, jEpoch
, jIteration :: Natural
}
| JobSynchroniseLdapUser { jUser :: UserId
}
| JobChangeUserDisplayEmail { jUser :: UserId
, jDisplayEmail :: UserEmail
}
| JobPruneSessionFiles
| JobPruneUnreferencedFiles { jNumIterations
, jEpoch
, jIteration :: Natural
}
| JobInjectFiles
| JobPruneFallbackPersonalisedSheetFilesKeys
| JobRechunkFiles
| JobDetectMissingFiles
| JobInjectFiles
| JobPruneFallbackPersonalisedSheetFilesKeys
| JobRechunkFiles
| JobDetectMissingFiles
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
| NotificationSheetSoonInactive { nSheet :: SheetId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationSheetHint { nSheet :: SheetId }
| NotificationSheetSolution { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
| NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
| NotificationExamRegistrationActive { nExam :: ExamId }
| NotificationExamRegistrationSoonInactive { nExam :: ExamId }
| NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
| NotificationExamResult { nExam :: ExamId }
| NotificationAllocationStaffRegister { nAllocations :: Set AllocationId }
| NotificationAllocationRegister { nAllocations :: Set AllocationId }
| NotificationAllocationAllocation { nAllocations :: Set AllocationId }
| NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId }
| NotificationExamOfficeExamResults { nExam :: ExamId }
| NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
| NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
| NotificationAllocationResults { nAllocation :: AllocationId }
| NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
| NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
| NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
| NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
data Notification
= NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
| NotificationSheetSoonInactive { nSheet :: SheetId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationSheetHint { nSheet :: SheetId }
| NotificationSheetSolution { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
| NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
| NotificationExamRegistrationActive { nExam :: ExamId }
| NotificationExamRegistrationSoonInactive { nExam :: ExamId }
| NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
| NotificationExamResult { nExam :: ExamId }
| NotificationAllocationStaffRegister { nAllocations :: Set AllocationId }
| NotificationAllocationRegister { nAllocations :: Set AllocationId }
| NotificationAllocationAllocation { nAllocations :: Set AllocationId }
| NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId }
| NotificationAllocationNewCourse { nAllocation :: AllocationId, nCourse :: CourseId }
| NotificationExamOfficeExamResults { nExam :: ExamId }
| NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
| NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
| NotificationAllocationResults { nAllocation :: AllocationId }
| NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
| NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
| NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
| NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job

View File

@ -45,6 +45,10 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag
import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
import Data.Time.Format.ISO8601 (iso8601Show)
import qualified Data.Time.Zones as TZ
-- Database versions must follow https://pvp.haskell.org:
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@ -168,6 +172,19 @@ migrateManual = do
, ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )
, ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" )
]
recordedChangelogItems <- lift . lift $ selectList [] []
let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems'
where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ]
unless (null missingChangelogItems) $ do
now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
addMigration False $
let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|]
vals = Text.intercalate ", " $ do
item <- missingChangelogItems
return [st|('#{toPathPiece item}', '#{now}')|]
in sql
where
addIndex :: Text -> Sql -> Migration
addIndex ixName ixDef = do
@ -950,6 +967,26 @@ customMigrations = Map.fromListWith (>>)
INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
|]
)
, ( AppliedMigrationKey [migrationVersion|41.0.0|] [version|42.0.0|]
, do
whenM (tableExists "exam")
[executeQQ|
ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing};
|]
whenM (tableExists "school")
[executeQQ|
ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse};
|]
)
, ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
, unlessM (tableExists "changelog_item_first_seen") $ do
[executeQQ|
CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL);
|]
insertMany_ [ ChangelogItemFirstSeen{..}
| (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays
]
)
]

View File

@ -18,3 +18,4 @@ import Model.Types.Languages as Types
import Model.Types.File as Types
import Model.Types.User as Types
import Model.Types.Workflow as Types
import Model.Types.Changelog as Types

View File

@ -0,0 +1,145 @@
module Model.Types.Changelog
( ChangelogItem(..)
, changelogItemMap
, ChangelogItemKind(..), _ChangelogItemFeature, _ChangelogItemBugfix
, classifyChangelogItem
, changelogItemDays
) where
import Import.NoModel
import Model.Types.TH.PathPiece
import qualified Data.Map as Map
mkI18nWidgetEnum "Changelog" "changelog"
derivePersistFieldPathPiece ''ChangelogItem
pathPieceJSONKey ''ChangelogItem
pathPieceJSON ''ChangelogItem
pathPieceHttpApiData ''ChangelogItem
data ChangelogItemKind
= ChangelogItemFeature
| ChangelogItemBugfix
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
makePrisms ''ChangelogItemKind
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
classifyChangelogItem = \case
ChangelogHaskellCampusLogin -> ChangelogItemBugfix
ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
ChangelogPassingByPointsWorks -> ChangelogItemBugfix
ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
ChangelogFormsTimesReset -> ChangelogItemBugfix
_other -> ChangelogItemFeature
changelogItemDays :: Map ChangelogItem Day
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
[ (ChangelogConfigurableDatetimeFormat, [day|2018-07-10|])
, (ChangelogCourseListOverAllTerms, [day|2018-07-31|])
, (ChangelogCorrectionsDisplayImprovements, [day|2018-07-31|])
, (ChangelogHaskellCampusLogin, [day|2018-08-01|])
, (ChangelogFileDownloadOption, [day|2018-08-06|])
, (ChangelogSheetsNoSubmissionAndZipControl, [day|2018-09-18|])
, (ChangelogSmartCorrectionDistribution, [day|2018-09-18|])
, (ChangelogTableSummaries, [day|2018-09-18|])
, (ChangelogPersonalInformation, [day|2018-09-18|])
, (ChangelogCourseShorthandsWithinSchools, [day|2018-09-18|])
, (ChangelogTooltipsWithoutJavascript, [day|2018-09-18|])
, (ChangelogEmailNotifications, [day|2018-10-19|])
, (ChangelogSupportWidget, [day|2018-10-19|])
, (ChangelogAccountDeletionDuringTesting, [day|2018-10-19|])
, (ChangelogImprovementsForCorrectors, [day|2018-11-09|])
, (ChangelogButtonsWorkWithoutJavascript, [day|2018-11-09|])
, (ChangelogTableFormsWorkAfterAjax, [day|2018-11-29|])
, (ChangelogPassingByPointsWorks, [day|2018-11-30|])
, (ChangelogErrorMessagesForTableItemVanish, [day|2019-01-16|])
, (ChangelogAssignedCorrectionsFilters, [day|2019-01-16|])
, (ChangelogCourseConvenienceLinks, [day|2019-01-16|])
, (ChangelogAsidenav, [day|2019-01-30|])
, (ChangelogCourseAssociatedStudyField, [day|2019-03-20|])
, (ChangelogStudyFeatures, [day|2019-03-27|])
, (ChangelogCourseAdministratorRoles, [day|2019-03-27|])
, (ChangelogCourseAdministratorInvitations, [day|2019-04-20|])
, (ChangelogCourseMessages, [day|2019-04-20|])
, (ChangelogCorrectorsOnCourseShow, [day|2019-04-29|])
, (ChangelogTutorials, [day|2019-04-29|])
, (ChangelogCourseMaterials, [day|2019-05-04|])
, (ChangelogDownloadAllSheetFiles, [day|2019-05-10|])
, (ChangelogImprovedSubmittorUi, [day|2019-05-10|])
, (ChangelogCourseRegisterByAdmin, [day|2019-05-13|])
, (ChangelogReworkedAutomaticCorrectionDistribution, [day|2019-05-20|])
, (ChangelogDownloadAllSheetFilesByType, [day|2019-06-07|])
, (ChangelogSheetSpecificFiles, [day|2019-06-07|])
, (ChangelogExams, [day|2019-06-26|])
, (ChangelogCsvExamParticipants, [day|2019-07-23|])
, (ChangelogAllocationCourseRegistration, [day|2019-08-12|])
, (ChangelogAllocationApplications, [day|2019-08-19|])
, (ChangelogCsvCourseApplications, [day|2019-08-27|])
, (ChangelogAllocationsNotifications, [day|2019-09-05|])
, (ChangelogConfigurableDisplayEmails, [day|2019-09-12|])
, (ChangelogConfigurableDisplayNames, [day|2019-09-12|])
, (ChangelogEstimateAllocatedCourseCapacity, [day|2019-09-12|])
, (ChangelogNotificationExamRegistration, [day|2019-09-13|])
, (ChangelogExamClosure, [day|2019-09-16|])
, (ChangelogExamOfficeExamNotification, [day|2019-09-16|])
, (ChangelogExamOffices, [day|2019-09-16|])
, (ChangelogExamAchievementParticipantDuplication, [day|2019-09-25|])
, (ChangelogFormsTimesReset, [day|2019-09-25|])
, (ChangelogExamAutomaticResults, [day|2019-09-25|])
, (ChangelogExamAutomaticBoni, [day|2019-09-25|])
, (ChangelogAutomaticallyAcceptCourseApplications, [day|2019-09-27|])
, (ChangelogCourseNews, [day|2019-10-01|])
, (ChangelogCsvExportCourseParticipants, [day|2019-10-08|])
, (ChangelogNotificationCourseParticipantViaAdmin, [day|2019-10-08|])
, (ChangelogCsvExportCourseParticipantsFeatures, [day|2019-10-09|])
, (ChangelogCourseOccurences, [day|2019-10-09|])
, (ChangelogTutorialRegistrationViaParticipantTable, [day|2019-10-10|])
, (ChangelogCsvExportCourseParticipantsRegisteredTutorials, [day|2019-10-10|])
, (ChangelogCourseParticipantsSex, [day|2019-10-14|])
, (ChangelogTutorialTutorControl, [day|2019-10-14|])
, (ChangelogCsvOptionCharacterSet, [day|2019-10-23|])
, (ChangelogCsvOptionTimestamp, [day|2019-10-23|])
, (ChangelogEnglish, [day|2019-10-31|])
, (ChangelogI18n, [day|2019-10-31|])
, (ChangelogLmuInternalFields, [day|2019-11-28|])
, (ChangelogNotificationSubmissionChanged, [day|2019-12-05|])
, (ChangelogExportCourseParticipants, [day|2020-01-17|])
, (ChangelogExternalExams, [day|2020-01-17|])
, (ChangelogExamAutomaticRoomDistribution, [day|2020-01-29|])
, (ChangelogWarningMultipleSemesters, [day|2020-01-30|])
, (ChangelogExamAutomaticRoomDistributionBetterRulesDisplay, [day|2020-01-30|])
, (ChangelogReworkedNavigation, [day|2020-02-07|])
, (ChangelogExamCorrect, [day|2020-02-08|])
, (ChangelogExamGradingMode, [day|2020-02-19|])
, (ChangelogMarkdownEmails, [day|2020-02-23|])
, (ChangelogMarkdownHtmlInput, [day|2020-02-23|])
, (ChangelogBetterCsvImport, [day|2020-03-06|])
, (ChangelogAdditionalDatetimeFormats, [day|2020-03-16|])
, (ChangelogServerSideSessions, [day|2020-03-16|])
, (ChangelogWebinterfaceAllocationAllocation, [day|2020-03-16|])
, (ChangelogBetterTableCellColourCoding, [day|2020-03-16|])
, (ChangelogCourseOccurrenceNotes, [day|2020-03-31|])
, (ChangelogHideSystemMessages, [day|2020-04-15|])
, (ChangelogNonAnonymisedCorrection, [day|2020-04-17|])
, (ChangelogBetterCourseParticipantDetailPage, [day|2020-04-17|])
, (ChangelogFaq, [day|2020-04-24|])
, (ChangelogRegisteredSubmissionGroups, [day|2020-04-28|])
, (ChangelogFormerCourseParticipants, [day|2020-05-05|])
, (ChangelogBetterFileUploads, [day|2020-05-05|])
, (ChangelogSheetPassAlways, [day|2020-05-23|])
, (ChangelogBetterCourseCommunicationTutorials, [day|2020-05-25|])
, (ChangelogAdditionalSheetNotifications, [day|2020-05-25|])
, (ChangelogCourseParticipantsListAddSheets, [day|2020-06-14|])
, (ChangelogYamlRatings, [day|2020-06-17|])
, (ChangelogSubmissionOnlyExamRegistered, [day|2020-07-20|])
, (ChangelogCourseVisibility, [day|2020-08-10|])
, (ChangelogPersonalisedSheetFiles, [day|2020-08-10|])
, (ChangelogAbolishCourseAssociatedStudyFeatures, [day|2020-08-28|])
]

View File

@ -32,6 +32,12 @@ module Model.Types.Exam
, hasExamGradingPass, hasExamGradingGrades
, ExamPartNumber
, _ExamPartNumber, _ExamPartNumber'
, ExamAids(..), ExamAidsPreset(..)
, ExamOnline(..), ExamOnlinePreset(..)
, ExamSynchronicity(..), ExamSynchronicityPreset(..)
, ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..)
, ExamMode(..)
, ExamModePredicate(..), ExamModeDNF(..)
) where
import Import.NoModel
@ -59,6 +65,8 @@ import qualified Data.Foldable
import Data.Aeson (genericToJSON, genericParseJSON)
import Model.Types.Security
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
@ -427,3 +435,125 @@ pathPieceJSONKey ''ExamPartNumber
instance Enum ExamPartNumber where
toEnum = review _ExamPartNumber' . toEnum
fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber'
data ExamAids
= ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
| ExamAidsCustom { examAidsCustom :: Html }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data ExamAidsPreset
= ExamOpenBook
| ExamClosedBook
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2
, fieldLabelModifier = camelToPathPiece' 2
, sumEncoding = TaggedObject "mode" "data"
} ''ExamAids
derivePersistFieldJSON ''ExamAids
nullaryPathPiece' ''ExamAidsPreset $ nameToPathPiece' 1
pathPieceJSON ''ExamAidsPreset
data ExamOnline
= ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
| ExamOnlineCustom { examOnlineCustom :: Html }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data ExamOnlinePreset
= ExamOnline
| ExamOffline
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2
, fieldLabelModifier = camelToPathPiece' 2
, sumEncoding = TaggedObject "mode" "data"
} ''ExamOnline
derivePersistFieldJSON ''ExamOnline
nullaryPathPiece' ''ExamOnlinePreset $ nameToPathPiece' 1
pathPieceJSON ''ExamOnlinePreset
data ExamSynchronicity
= ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
| ExamSynchronicityCustom { examSynchronicityCustom :: Html }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data ExamSynchronicityPreset
= ExamSynchronous
| ExamAsynchronous
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2
, fieldLabelModifier = camelToPathPiece' 2
, sumEncoding = TaggedObject "mode" "data"
} ''ExamSynchronicity
derivePersistFieldJSON ''ExamSynchronicity
nullaryPathPiece' ''ExamSynchronicityPreset $ nameToPathPiece' 1
pathPieceJSON ''ExamSynchronicityPreset
data ExamRequiredEquipment
= ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
| ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data ExamRequiredEquipmentPreset
= ExamRequiredEquipmentNone
| ExamRequiredEquipmentPen
| ExamRequiredEquipmentPaperPen
| ExamRequiredEquipmentCalculatorPen
| ExamRequiredEquipmentCalculatorPaperPen
| ExamRequiredEquipmentWebcamMicrophoneInternet
| ExamRequiredEquipmentMicrophoneInternet
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2
, fieldLabelModifier = camelToPathPiece' 2
, sumEncoding = TaggedObject "mode" "data"
} ''ExamRequiredEquipment
derivePersistFieldJSON ''ExamRequiredEquipment
nullaryPathPiece' ''ExamRequiredEquipmentPreset $ nameToPathPiece' 3
pathPieceJSON ''ExamRequiredEquipmentPreset
data ExamMode = ExamMode
{ examAids :: Maybe ExamAids
, examOnline :: Maybe ExamOnline
, examSynchronicity :: Maybe ExamSynchronicity
, examRequiredEquipment :: Maybe ExamRequiredEquipment
}
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue
} ''ExamMode
derivePersistFieldJSON ''ExamMode
data ExamModePredicate
= ExamModePredAids ExamAidsPreset
| ExamModePredOnline ExamOnlinePreset
| ExamModePredSynchronicity ExamSynchronicityPreset
| ExamModePredRequiredEquipment ExamRequiredEquipmentPreset
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 3
, sumEncoding = TaggedObject "setting" "preset"
} ''ExamModePredicate
derivePathPiece ''ExamModePredicate (camelToPathPiece' 3) "--"
deriveFinite ''ExamModePredicate
newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece)
derivePersistFieldJSON ''ExamModeDNF

View File

@ -43,6 +43,7 @@ data NotificationTrigger
| NTAllocationStaffRegister
| NTAllocationAllocation
| NTAllocationRegister
| NTAllocationNewCourse
| NTAllocationOutdatedRatings
| NTAllocationUnratedApplications
| NTAllocationResults
@ -72,6 +73,7 @@ instance Default NotificationSettings where
defaultOff = HashSet.fromList
[ NTSheetSoonInactive
, NTExamRegistrationSoonInactive
, NTAllocationNewCourse
]
instance ToJSON NotificationSettings where

View File

@ -184,6 +184,9 @@ dnfAssumeValue var val
disagrees PLNegated{..} = plVar == var && val
disagrees PLVariable{..} = plVar == var && not val
predDNFFalse :: PredDNF a
predDNFFalse = PredDNF Set.empty
data UserGroupName
= UserGroupMetrics

View File

@ -12,6 +12,7 @@ module Settings
, module Settings.Mime
, module Settings.Cookies
, module Settings.Log
, module Settings.Locale
) where
import Import.NoModel
@ -55,6 +56,7 @@ import Settings.Cluster
import Settings.Mime
import Settings.Cookies
import Settings.Log
import Settings.Locale
import qualified System.FilePath as FilePath
@ -605,10 +607,3 @@ compileTimeAppSettings =
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Aeson.Error e -> error e
Aeson.Success settings -> settings
getTimeLocale' :: [Lang] -> TimeLocale
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
appTZ :: TZ
appTZ = $(includeSystemTZ "Europe/Berlin")

21
src/Settings/Locale.hs Normal file
View File

@ -0,0 +1,21 @@
module Settings.Locale
( getTimeLocale'
, appTZ
, appLanguages
) where
import Utils.DateTime
import Data.List.NonEmpty
import Text.Shakespeare.I18N (Lang)
getTimeLocale' :: [Lang] -> TimeLocale
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
appTZ :: TZ
appTZ = $(includeSystemTZ "Europe/Berlin")
appLanguages :: NonEmpty Lang
appLanguages = "de-de-formal" :| ["en-eu"]

View File

@ -32,6 +32,7 @@ import Utils.Cookies.Registered as Utils
import Utils.Session as Utils
import Utils.Csv as Utils
import Utils.I18n as Utils
import Utils.NTop as Utils
import Text.Blaze (Markup, ToMarkup)
@ -115,7 +116,7 @@ import qualified Control.Monad.Random.Lazy as LazyRand
import Data.Data (Data)
import qualified Data.Text.Lazy.Builder as Builder
import Unsafe.Coerce
import Data.Coerce
import System.FilePath as Utils (addExtension, isExtensionOf)
import System.FilePath (dropDrive)
@ -660,16 +661,7 @@ ignoreNothing _ Nothing y = y
ignoreNothing _ x Nothing = x
ignoreNothing f (Just x) (Just y) = Just $ f x y
newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
instance Eq a => Eq (NTop (Maybe a)) where
(NTop x) == (NTop y) = x == y
instance Ord a => Ord (NTop (Maybe a)) where
compare (NTop Nothing) (NTop Nothing) = EQ
compare (NTop Nothing) _ = GT
compare _ (NTop Nothing) = LT
compare (NTop (Just x)) (NTop (Just y)) = compare x y
-- `NTop` moved to `Utils.NTop`
exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
@ -1264,8 +1256,8 @@ instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
mempty = MergeHashMap HashMap.empty
instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
parseJSON = case Aeson.fromJSONKey of
Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $
uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson.<?> Aeson.Key k)
Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $
coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
@ -1273,9 +1265,6 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
where
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
uc = unsafeCoerce
parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
where
@ -1290,6 +1279,61 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
newtype MergeMap k v = MergeMap { unMergeMap :: Map k v }
deriving (Show, Generic, Typeable, Data)
deriving newtype ( Eq, Ord
, Functor, Foldable, NFData
, ToJSON
)
makePrisms ''MergeMap
makeWrapped ''MergeMap
type instance Element (MergeMap k v) = v
instance MonoFoldable (MergeMap k v)
instance MonoFunctor (MergeMap k v)
instance MonoTraversable (MergeMap k v)
instance Traversable (MergeMap k) where
traverse = _MergeMap . traverse
instance FunctorWithIndex k (MergeMap k)
instance TraversableWithIndex k (MergeMap k) where
itraverse = _MergeMap .> itraverse
instance FoldableWithIndex k (MergeMap k)
instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where
(MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b
instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where
mempty = MergeMap Map.empty
instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where
parseJSON = case Aeson.fromJSONKey of
Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $
coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $
fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $
fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
where
parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
where
p = Aeson.withArray "(k, v)" $ \ab ->
let n = V.length ab
in if n == 2
then (,) <$> parseJSONElemAtIndex keyParser 0 ab
<*> parseJSONElemAtIndex valParser 1 ab
else fail $ "cannot unpack array of length " ++
show n ++ " into a pair"
parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
--------------
-- FilePath --
--------------

View File

@ -12,6 +12,7 @@ module Utils.DateTime
, nominalHour, nominalMinute
, minNominalYear, avgNominalYear
, module Zones
, day
) where
import ClassyPrelude.Yesod hiding (lift)
@ -23,12 +24,14 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ)
import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
import Data.Time.Format (FormatTime)
import Data.Time.Clock.System (systemEpochDay)
import qualified Data.Time.Format.ISO8601 as Time
import qualified Data.Time.Format as Time
import qualified Data.List.NonEmpty as NonEmpty
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Instances.TH.Lift ()
import Data.Data (Data)
@ -45,6 +48,8 @@ import Algebra.Lattice.Ordered
import Control.Monad.Fail
import Utils.Lang (selectLanguage')
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@ -142,3 +147,15 @@ nominalMinute = 60
minNominalYear, avgNominalYear :: NominalDiffTime
minNominalYear = 365 * nominalDay
avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
---------
-- Day --
---------
day :: QuasiQuoter
day = QuasiQuoter{..}
where
quotePat = error "day used as pattern"
quoteType = error "day used as type"
quoteDec = error "day used as declaration"
quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr

View File

@ -230,6 +230,8 @@ data FormIdentifier
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
| FIDAllocationAccept
| FIDTestDownload
| FIDAllocationRegister
| FIDAllocationNotification
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

View File

@ -6,19 +6,40 @@ module Utils.I18n
, renderMessageI18n
, i18nMessageFor
, Element
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import Settings.Locale (appLanguages)
import qualified Data.Aeson as JSON
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Map as Map
import qualified Data.Set as Set
import Model.Types.TH.JSON
import Data.Data (Data)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
import System.FilePath
import System.Directory (listDirectory)
import Utils.NTop
import Control.Lens (iforM)
import Control.Monad.Fail (fail)
data I18n a = I18n
{ i18nFallback :: a
@ -79,3 +100,18 @@ i18nMessageFor :: ( MonadHandler m
)
=> [Lang] -> msg -> m I18nText
i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg
i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do
let i18nDirectory = "templates" </> "i18n" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
fileKinds :: Map Text [Text]
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
iforM fileKinds $ \kind -> maybe (fail $ "" <> i18nDirectory <> " has no translations for " <> unpack kind <> "") return . NonEmpty.nonEmpty
i18nWidgetFilesAvailable :: FilePath -> Q Exp
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'

View File

@ -86,6 +86,10 @@ data Icon
| IconFileUploadSession
| IconStandaloneFieldError
| IconFileUser
| IconNotification | IconNoNotification
| IconAllocationRegister | IconAllocationRegistrationEdit
| IconAllocationApplicationEdit
| IconPersonalIdentification
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
iconText :: Icon -> Text
@ -150,6 +154,12 @@ iconText = \case
IconFileUploadSession -> "file-upload"
IconStandaloneFieldError -> "exclamation"
IconFileUser -> "file-user"
IconNotification -> "envelope"
IconNoNotification -> "times"
IconAllocationRegister -> "user-plus"
IconAllocationRegistrationEdit -> "pencil-alt"
IconAllocationApplicationEdit -> "pencil-alt"
IconPersonalIdentification -> "id-card"
instance Universe Icon
instance Finite Icon

17
src/Utils/NTop.hs Normal file
View File

@ -0,0 +1,17 @@
module Utils.NTop
( NTop(..)
) where
import ClassyPrelude
-- | treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
newtype NTop a = NTop { nBot :: a }
deriving (Read, Show, Generic, Typeable)
deriving newtype (Eq)
instance Ord a => Ord (NTop (Maybe a)) where
compare (NTop Nothing) (NTop Nothing) = EQ
compare (NTop Nothing) _ = GT
compare _ (NTop Nothing) = LT
compare (NTop (Just x)) (NTop (Just y)) = compare x y

View File

@ -8,6 +8,7 @@ module Utils.PathPiece
, tuplePathPiece
, pathPieceJSON, pathPieceJSONKey
, pathPieceBinary
, pathPieceHttpApiData
) where
import ClassyPrelude.Yesod
@ -27,7 +28,7 @@ import qualified Data.HashMap.Strict as HashMap
import Numeric.Natural
import Data.List (foldl)
import Data.List (nub, foldl)
import Data.Aeson.Types
import qualified Data.Aeson.Types as Aeson
@ -37,6 +38,11 @@ import Control.Monad.Fail
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Control.Lens
import Data.Generics.Product.Types
import Web.HttpApiData
mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
mkFiniteFromPathPiece finiteType = do
@ -105,7 +111,7 @@ derivePathPiece adt mangle joinPP = do
[]
finDecs =
[ pragInlD mapName NoInline FunLike AllPhases
, sigD mapName [t|HashMap Text ([Text] -> Maybe $(conT adt))|]
, sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
, funD mapName
[ clause [] (normalB finClause) [] ]
]
@ -123,8 +129,17 @@ derivePathPiece adt mangle joinPP = do
, match wildP (normalB [e|Nothing|]) []
]
]
typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars
iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars
usesVar ConstructorInfo{..} n
| n `elem` map tvarName constructorVars = False
| otherwise = any (elemOf types n) constructorFields
fieldTypes = nub $ concatMap constructorFields datatypeCons
tvarName (PlainTV n) = n
tvarName (KindedTV n _) = n
sequence . (finDecs ++ ) . pure $
instanceD (cxt []) [t|PathPiece $(conT adt)|]
instanceD (cxt iCxt) [t|PathPiece $(typ)|]
[ funD 'toPathPiece
(map toClause datatypeCons)
, funD 'fromPathPiece
@ -217,3 +232,11 @@ pathPieceBinary tName
get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece
put = Binary.put . toPathPiece
|]
pathPieceHttpApiData :: Name -> DecsQ
pathPieceHttpApiData tName
= [d| instance ToHttpApiData $(conT tName) where
toUrlPiece = toPathPiece
instance FromHttpApiData $(conT tName) where
parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece
|]

View File

@ -7,10 +7,9 @@ import Data.List (findIndex)
getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
=> NonEmpty Lang -- ^ `appLanguages`
-> SystemMessageId
=> SystemMessageId
-> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
SystemMessage{..} <- MaybeT $ get smId
translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
let

View File

@ -13,8 +13,18 @@ import Language.Haskell.TH.Datatype
import Data.List ((!!), foldl)
import Control.Lens
import Control.Monad.Fail
import Utils.I18n
import qualified Data.Char as Char
import Data.Universe (Universe, Finite)
import qualified Data.Map as Map
import qualified Data.Text as Text
import Utils.PathPiece
------------
-- Tuples --
------------
@ -188,3 +198,56 @@ dispatchTH dType = do
let fName = mkName $ "dispatch" <> nameBase constructorName
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
lamCaseE matches
mkI18nWidgetEnum :: String -> FilePath -> DecsQ
mkI18nWidgetEnum (splitCamel -> namebase) basename = do
itemsAvailable <- i18nWidgetFilesAvailable' basename
let items = Map.mapWithKey (\k _ -> typPrefix <> unPathPiece k) itemsAvailable
sequence
[ dataD (cxt []) dataName [] Nothing
[ normalC (mkName conName) []
| (_, conName) <- Map.toAscList items
]
[ derivClause (Just StockStrategy)
[ conT ''Eq
, conT ''Ord
, conT ''Read
, conT ''Show
, conT ''Enum
, conT ''Bounded
, conT ''Generic
, conT ''Typeable
]
, derivClause (Just AnyclassStrategy)
[ conT ''Universe
, conT ''Finite
]
]
, instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
[ funD 'toPathPiece
[ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
| (int, con) <- Map.toList items
]
, funD 'fromPathPiece
[ clause [varP $ mkName "t"]
( guardedB
[ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
| (int, con) <- Map.toList items
]) []
, clause [wildP] (normalB [e|Nothing|]) []
]
]
, sigD (mkName $ valPrefix <> "ItemMap") [t|Map Text $(conT dataName)|]
, funD (mkName $ valPrefix <> "ItemMap")
[ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
]
]
where
unPathPiece :: Text -> String
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
dataName = mkName $ typPrefix <> "Item"
typPrefix = concat $ over (takingWhile Char.isLower $ _head . traverse) Char.toUpper namebase
valPrefix = concat $ over (takingWhile Char.isUpper $ _head . traverse) Char.toLower namebase

View File

@ -73,6 +73,9 @@ extra-deps:
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
- primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
- aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
- data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
- strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
resolver: nightly-2020-08-08
compiler: ghc-8.10.2

View File

@ -276,6 +276,27 @@ packages:
sha256: 924e88629b493abb6b2f3c3029cef076554a2b627091e3bb6887ec03487a707d
original:
hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
- completed:
hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
pantry-tree:
size: 39759
sha256: 6290ffac2ea3e52b57d869306d12dbf32c07d17099f695f035ff7f756677831d
original:
hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
- completed:
hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
pantry-tree:
size: 261
sha256: 6cf43af344624e087dbe2f1e96e985de6142e85bb02db8449df6d72bee3c1013
original:
hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
- completed:
hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
pantry-tree:
size: 654
sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908
original:
hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
snapshots:
- completed:
size: 524392

View File

@ -65,7 +65,7 @@ $newline never
<dd .deflist__dd>
<p>^{formatTimeW SelFormatDateTime toT}
<section id=allocation-participation>
<section #allocation-participation>
<h2>
_{MsgAllocationParticipation}
$if is _Nothing muid
@ -94,6 +94,18 @@ $newline never
$# This redundant links prevents useless help requests from frantic users
^{allocationInfoModal}
<section>
<h2>
_{MsgAllocationNotificationNewCourse}
$if is _Just muid
<p .explanation>
_{MsgAllocationNotificationNewCourseTip}
<br>
_{bool MsgAllocationNotificationNewCourseCurrentlyOff MsgAllocationNotificationNewCourseCurrentlyOn wouldNotifyNewCourse}
^{notificationForm'}
$else
_{MsgAllocationNotificationLoginFirst}
$if not (null courseWidgets)
<section .allocation>
<h2>

View File

@ -0,0 +1,14 @@
$newline never
<dl .deflist #changelog>
$forall (Down d, es) <- Map.toList changelogEntries
<dt .deflist__dt ##{"changelog-date--" <> toPathPiece d}>
^{formatTimeW SelFormatDate d}
<dd .deflist__dd>
<ul>
$forall e <- Set.toList es
<li ##{"changelog-item--" <> toPathPiece e}>
$if is _ChangelogItemBugfix $ classifyChangelogItem e
<i>
_{ChangelogItemBugfix}
: #
^{changelogItems ! toPathPiece e}

View File

@ -20,6 +20,9 @@ $maybe desc <- examDescription
#{desc}
<section>
$maybe warn <- notificationDiscouragedExamMode
^{warn}
<dl .deflist>
$if not examVisible
<dt .deflist__dt>_{MsgExamVisibleFrom}
@ -41,6 +44,41 @@ $maybe desc <- examDescription
$maybe publishAssignments <- examPublishOccurrenceAssignments
<dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
$maybe online <- examOnline examExamMode
<dt .deflist__dt>_{MsgExamShowOnline}
<dd .deflist__dd>
$case online
$of ExamOnlinePreset p
^{examOnlinePresetWidget p}
$of ExamOnlineCustom c
#{c}
$maybe synchronicity <- examSynchronicity examExamMode
<dt .deflist__dt>_{MsgExamShowSynchronicity}
<dd .deflist__dd>
$case synchronicity
$of ExamSynchronicityPreset p
^{examSynchronicityPresetWidget p}
$of ExamSynchronicityCustom c
#{c}
$maybe aids <- examAids examExamMode
<dt .deflist__dt>_{MsgExamShowAids}
<dd .deflist__dd>
$case aids
$of ExamAidsPreset p
^{examAidsPresetWidget p}
$of ExamAidsCustom c
#{c}
$maybe requiredEquipment <- examRequiredEquipment examExamMode
<dt .deflist__dt>_{MsgExamShowRequiredEquipment}
<dd .deflist__dd>
<p>
$case requiredEquipment
$of ExamRequiredEquipmentPreset p
^{examRequiredEquipmentPresetWidget p}
$of ExamRequiredEquipmentCustom c
#{c}
^{notificationPersonalIdentification}
$maybe room <- examRoom
<dt .deflist__dt>_{MsgExamRoom}
<dd .deflist__dd>#{room}
@ -89,6 +127,8 @@ $maybe desc <- examDescription
_{MsgExamRegistration}
<dd .deflist__dd>
^{registerWdgt}
$if is _Nothing (examRequiredEquipment examExamMode)
^{notificationPersonalIdentification}
$if showCloseWidget && is _Nothing examClosed
<section>

View File

@ -0,0 +1,4 @@
$newline never
Kursassoziierte Studienfächer wurden abgeschafft.
<br>
Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.

View File

@ -0,0 +1,4 @@
$newline never
Abolished course-associated features of study.
<br>
In course-related contexts now all study features which were up to date during the relevant term are displayed.

View File

@ -0,0 +1,2 @@
$newline never
Benutzer können sich in der Testphase komplett selbst löschen

View File

@ -0,0 +1,2 @@
$newline never
During testing users may completely delete their accounts

View File

@ -0,0 +1,2 @@
$newline never
Zusätzliche Uhrzeit- und Datumsformate

View File

@ -0,0 +1,2 @@
$newline never
Additional date and time formats

View File

@ -0,0 +1,2 @@
$newline never
Zusätzliche Benachrichtigungen für Übungsblätter

View File

@ -0,0 +1,2 @@
$newline never
Additional notifications for exercise sheets

View File

@ -0,0 +1,2 @@
$newline never
Bewerbungen für Zentralanmeldungen

View File

@ -0,0 +1,2 @@
$newline never
Applications for central allocations

View File

@ -0,0 +1,2 @@
$newline never
Kurse zu Zentralanmeldungen eintragen

View File

@ -0,0 +1,2 @@
$newline never
Registration of courses for central allocation

View File

@ -0,0 +1,2 @@
$newline never
Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden

View File

@ -0,0 +1,2 @@
$newline never
Notifications for new courses being added to central allocations

View File

@ -0,0 +1,2 @@
$newline never
Benachrichtigungen für Zentralanmeldungen

View File

@ -0,0 +1,2 @@
$newline never
Notifications for central allocations

View File

@ -0,0 +1,2 @@
$newline never
Designänderungen

View File

@ -0,0 +1,2 @@
$newline never
Design changes

View File

@ -0,0 +1,2 @@
$newline never
Liste zugewiesener Abgaben lassen sich nun filtern

View File

@ -0,0 +1,2 @@
$newline never
Filters for list of assigned corrections

View File

@ -0,0 +1,2 @@
$newline never
Automatische Anmeldung von Bewerbern in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung)

View File

@ -0,0 +1,2 @@
$newline never
Option to automatically accept applications for courses outside of central allocations

View File

@ -0,0 +1,2 @@
$newline never
Besseres Verschicken von Kursmitteilungen an Tutoriumsteilnehmer

View File

@ -0,0 +1,2 @@
$newline never
Better sending of course communications to tutorial participants

View File

@ -0,0 +1,2 @@
$newline never
Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer

View File

@ -0,0 +1,2 @@
$newline never
Submissions, tutorials, and exams are now shown on the detail page for course participants

View File

@ -0,0 +1,2 @@
$newline never
Verbesserter Workflow & Fehlerbehandlung für CSV-Import

View File

@ -0,0 +1,2 @@
$newline never
Improved workflow and error-handling for CSV-import

View File

@ -0,0 +1,2 @@
$newline never
Verbesserte Handhabung von Datei-Uploads

View File

@ -0,0 +1,2 @@
$newline never
Improved handling of file uploads

View File

@ -0,0 +1,2 @@
$newline never
Verbesserte Farbkodierung von Tabellenzellen

View File

@ -0,0 +1,2 @@
$newline never
Improved colour coding of table cells

View File

@ -0,0 +1,2 @@
$newline never
Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript

View File

@ -0,0 +1,2 @@
$newline never
Multiple buttons/forms no work again when JavaScript is enabled

View File

@ -0,0 +1,2 @@
$newline never
Wählbares Format für Datum

Some files were not shown because too many files have changed in this diff Show More