From 18921e06d1deeb41d705eabacc2d348bac76197f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 24 Sep 2020 21:48:23 +0200 Subject: [PATCH] feat(allocations): notify about new courses --- messages/uniworx/de-de-formal.msg | 23 +++ messages/uniworx/en-eu.msg | 23 +++ models/allocations.model | 6 + package.yaml | 2 +- routes | 2 +- .../Universe/Instances/Reverse/WithIndex.hs | 2 +- src/Data/Void/Instances.hs | 3 + src/Handler/Allocation/Application.hs | 14 +- src/Handler/Allocation/Register.hs | 13 ++ src/Handler/Allocation/Show.hs | 79 +++++++++- src/Handler/Course/Edit.hs | 13 +- src/Handler/Profile.hs | 93 ++++++++++- src/Handler/Utils/Form.hs | 44 +++--- src/Import/NoModel.hs | 2 +- src/Jobs/Handler/QueueNotification.hs | 41 ++++- .../Handler/SendNotification/Allocation.hs | 22 +++ src/Jobs/Types.hs | 147 +++++++++--------- src/Model/Types/Mail.hs | 2 + src/Utils.hs | 64 +++++++- src/Utils/Form.hs | 2 + src/Utils/Icon.hs | 8 + stack.yaml | 3 + stack.yaml.lock | 21 +++ templates/allocation/show.hamlet | 14 +- templates/i18n/changelog/de-de-formal.hamlet | 7 + templates/i18n/changelog/en-eu.hamlet | 7 + templates/mail/allocationNewCourse.hamlet | 32 ++++ 27 files changed, 550 insertions(+), 139 deletions(-) create mode 100644 templates/mail/allocationNewCourse.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ff7a2f644..cda88415c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -789,6 +789,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. @@ -1132,6 +1141,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, für die ich mich beworben habe +NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer @@ -2200,6 +2211,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 @@ -2291,6 +2309,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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5a28dab5c..38b6f384f 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -786,6 +786,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. @@ -1133,6 +1142,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 already made applications +NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation NotificationTriggerKindAll: For all users NotificationTriggerKindCourseParticipant: For course participants @@ -2199,6 +2210,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 @@ -2291,6 +2309,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 diff --git a/models/allocations.model b/models/allocations.model index 64f395a4d..f063a50ea 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -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 \ No newline at end of file diff --git a/package.yaml b/package.yaml index cdc6fdba0..3a0ae72e1 100644 --- a/package.yaml +++ b/package.yaml @@ -25,7 +25,7 @@ dependencies: - directory - warp - data-default - - aeson + - aeson >=1.5 - conduit - monad-logger - fast-logger diff --git a/routes b/routes index 810aeb824..6a60ab694 100644 --- a/routes +++ b/routes @@ -109,7 +109,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 diff --git a/src/Data/Universe/Instances/Reverse/WithIndex.hs b/src/Data/Universe/Instances/Reverse/WithIndex.hs index ff6550058..66e6206cd 100644 --- a/src/Data/Universe/Instances/Reverse/WithIndex.hs +++ b/src/Data/Universe/Instances/Reverse/WithIndex.hs @@ -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 diff --git a/src/Data/Void/Instances.hs b/src/Data/Void/Instances.hs index a59e0cd39..fc0abbb22 100644 --- a/src/Data/Void/Instances.hs +++ b/src/Data/Void/Instances.hs @@ -10,3 +10,6 @@ instance ToContent Void where toContent = absurd instance ToTypedContent Void where toTypedContent = absurd + +instance RenderMessage site Void where + renderMessage _ _ = absurd diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index f48db411e..7996f3af3 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -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] diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index 9629335c7..3a6a4eb0c 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -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 diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 1df2e5506..061e8aed8 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -1,5 +1,5 @@ module Handler.Allocation.Show - ( getAShowR + ( getAShowR, postAShowR ) where import Import @@ -15,9 +15,36 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html -getAShowR tid ssh ash = do - muid <- maybeAuthId +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 + mAuth <- maybeAuth + let muid = entityKey <$> mAuth 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, notificationSetting) <- 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) + notificationSetting <- fmap join . for muid $ getBy . flip UniqueAllocationNotificationSetting aId + + return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, notificationSetting) 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,42 @@ getAShowR tid ssh ash = do , formAnchor = Nothing :: Maybe Text } + let wouldNotifyNewCourse = case (mAuth, notificationSetting) of + (_, Just (Entity _ AllocationNotificationSetting{..})) + -> not allocationNotificationSettingIsOptOut + (Just (Entity _ User{..}), _) + -> any (has $ _2 . _Just) courses && notificationAllowed userNotificationSettings NTAllocationNewCourse + _other + -> False + ((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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a4ed224a0..ab1548823 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 04518240d..a71375fc1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4be16133b..405ecd294 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1327,35 +1327,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 @@ -1367,16 +1360,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) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 0f29237c5..23e4f09b3 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -65,7 +65,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 () diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 38fa2a3f0..d653faf3e 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -22,21 +22,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 +49,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 +284,27 @@ determineNotificationCandidates = awaitForever $ \notif -> do -> withNotif . yieldMMany $ getEntity nUser NotificationSubmissionUserDeleted{..} -> withNotif . yieldMMany $ getEntity nUser + NotificationAllocationNewCourse{..} + -> withNotifOverride . E.selectSource . E.from $ \user -> do + let hasOverride overrideVal = E.exists . E.from $ \allocationNotificationSetting -> + E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. user E.^. UserId + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. E.val nAllocation + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut E.==. E.val (not overrideVal) + + hasApplication = E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + + E.where_ $ hasOverride True E.||. hasApplication + + E.where_ . E.not_ $ hasOverride False + + 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 True, user) classifyNotification :: Notification -> DB NotificationTrigger @@ -315,3 +339,4 @@ classifyNotification NotificationCourseRegistered{} = return NTCou classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted +classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 0f9a50741..24c517239 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -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") diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 504264894..831d73366 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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 diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index cbb7af356..dca966dd4 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 4e0a169a5..aa4906ed3 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -114,7 +114,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) @@ -1258,8 +1258,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" $ @@ -1267,9 +1267,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 @@ -1284,6 +1281,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 -- -------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 307bd6fad..a87f20b21 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,6 +229,8 @@ data FormIdentifier | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDAllocationAccept | FIDTestDownload + | FIDAllocationRegister + | FIDAllocationNotification deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e401f2db7..f8f8c9ca2 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -86,6 +86,9 @@ data Icon | IconFileUploadSession | IconStandaloneFieldError | IconFileUser + | IconNotification | IconNoNotification + | IconAllocationRegister | IconAllocationRegistrationEdit + | IconAllocationApplicationEdit deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text @@ -150,6 +153,11 @@ iconText = \case IconFileUploadSession -> "file-upload" IconStandaloneFieldError -> "exclamation" IconFileUser -> "file-user" + IconNotification -> "envelope" + IconNoNotification -> "times" + IconAllocationRegister -> "user-plus" + IconAllocationRegistrationEdit -> "pencil-alt" + IconAllocationApplicationEdit -> "pencil-alt" instance Universe Icon instance Finite Icon diff --git a/stack.yaml b/stack.yaml index fbbcd4aaa..9ea2e6ee1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -75,6 +75,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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 053ebc2d9..d36679f52 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -359,6 +359,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 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index ec3a41cce..b99a98218 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -65,7 +65,7 @@ $newline never

^{formatTimeW SelFormatDateTime toT} -

+

_{MsgAllocationParticipation} $if is _Nothing muid @@ -94,6 +94,18 @@ $newline never $# This redundant links prevents useless help requests from frantic users ^{allocationInfoModal} +
+

+ _{MsgAllocationNotificationNewCourse} + $if is _Just muid +

+ _{MsgAllocationNotificationNewCourseTip} +
+ _{bool MsgAllocationNotificationNewCourseCurrentlyOff MsgAllocationNotificationNewCourseCurrentlyOn wouldNotifyNewCourse} + ^{notificationForm'} + $else + _{MsgAllocationNotificationLoginFirst} + $if not (null courseWidgets)

diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index e0e41fb22..7907b908a 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,12 @@ $newline never
+
+ ^{formatGregorianW 2020 09 24} +
+
    +
  • + Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden +
    ^{formatGregorianW 2020 08 28}
    diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index ef3f6e194..12f4a739e 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -1,5 +1,12 @@ $newline never
    +
    + ^{formatGregorianW 2020 09 24} +
    +
      +
    • + Notifications for new courses being added to central allocations +
      ^{formatGregorianW 2020 08 28}
      diff --git a/templates/mail/allocationNewCourse.hamlet b/templates/mail/allocationNewCourse.hamlet new file mode 100644 index 000000000..8c0b2ed5b --- /dev/null +++ b/templates/mail/allocationNewCourse.hamlet @@ -0,0 +1,32 @@ +$newline never +\ + + + +