feat(allocations): notify about new courses

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
 

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
 

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

package.yaml

@@ -25,7 +25,7 @@ dependencies:
   - directory
   - warp
   - data-default
-  - aeson
+  - aeson >=1.5
   - conduit
   - monad-logger
   - fast-logger

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

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

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

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
+data AllocationApplicationButton
-                                 | BtnAllocationApplicationEdit
+  = BtnAllocationApply
-                                 | BtnAllocationApplicationRetract
+  | BtnAllocationApplicationEdit
-                                 | BtnAllocationApplicationRate
+  | 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]
 

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

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
+data NotifyNewCourseButton
-getAShowR tid ssh ash = do
+  = BtnNotifyNewCourseForceOn
-  muid <- maybeAuthId
+  | 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
 

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
+  prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
-  userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
+  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

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
+  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do
-    lift . runDB $ update uid [ UserNotificationSettings =. ns ]
+    lift . runDB $ do
+      update uid [ UserNotificationSettings =. ns ]
+      setAllocationNotifications uid ans
     tell . pure =<< messageI Success MsgNotificationSettingsUpdate
 
   siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do

src/Handler/Utils/Form.hs

@@ -1327,35 +1327,28 @@ boolField mkNone = radioGroupField mkNone $ do
 
 
 
-sectionedFuncForm  :: forall k v m sec.
+sectionedFuncForm  :: forall f k v m sec.
-                      ( Finite k, Ord k
+                      ( 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' :: AForm m (f v)
-    funcForm' = Set.fromList universeF
+    funcForm' = wFormToAForm $ do
-              & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
+      (res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form
-              & fmap (Map.fromSet mkForm)
+        -> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form
-              & 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
 
-    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.
+funcForm :: forall f k v m.
-            ( Finite k, Ord k
+            ( TraversableWithIndex k f
             , MonadHandler m
             , HandlerSite m ~ UniWorX
             )
-         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+         => f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
-funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
+funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void)
 
 
 

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 ()
 

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.filterM (\(notification', override, Entity _ User{userNotificationSettings}) -> or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
-            .| C.map (\(notification', Entity uid _) -> JobSendNotification uid 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 ()
+  let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
-      withNotif c = toProducer c .| C.map (notif, )
+      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

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")

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

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

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" $
+      Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $
-          uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson.<?> Aeson.Key k)
+          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 --
 --------------

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

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

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

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

templates/allocation/show.hamlet

@@ -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>

templates/i18n/changelog/de-de-formal.hamlet

@@ -1,5 +1,12 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 09 24}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden
+
   <dt .deflist__dt>
     ^{formatGregorianW 2020 08 28}
   <dd .deflist__dd>

templates/i18n/changelog/en-eu.hamlet

@@ -1,5 +1,12 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 09 24}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Notifications for new courses being added to central allocations
+
   <dt .deflist__dt>
     ^{formatGregorianW 2020 08 28}
   <dd .deflist__dd>

templates/mail/allocationNewCourse.hamlet

@@ -0,0 +1,32 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{SomeMessage $ MsgMailSubjectAllocationNewCourse allocationName}
+
+    <p>
+      _{SomeMessage MsgMailAllocationNewCourseTip}
+      <br />
+      <a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
+        #{courseName}
+
+    $if mayApply
+      <p>
+        $if hasApplied
+          _{SomeMessage MsgMailAllocationNewCourseEditApplicationsHere}
+        $else
+          _{SomeMessage MsgMailAllocationNewCourseApplyHere}
+        <br />
+        <a href=#{allocUrl}>
+          #{allocationName}
+
+    ^{ihamletSomeMessage editNotifications}