feat(allocations): notifications
This commit is contained in:
parent
454a0ff469
commit
6d52ed5c4c
@ -860,6 +860,11 @@ NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Ü
|
||||
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
|
||||
NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert
|
||||
NotificationTriggerExamResult: Ich kann ein neues Prüfungsergebnis einsehen
|
||||
NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen
|
||||
NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten
|
||||
NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben
|
||||
NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden
|
||||
NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus
|
||||
|
||||
NotificationTriggerKindAll: Für alle Benutzer
|
||||
NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
|
||||
@ -869,6 +874,7 @@ NotificationTriggerKindLecturer: Für Dozenten
|
||||
NotificationTriggerKindAdmin: Für Administratoren
|
||||
NotificationTriggerKindExamOffice: Für das Prüfungsamt
|
||||
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
|
||||
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen
|
||||
|
||||
CorrCreate: Abgaben erstellen
|
||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||
@ -1596,4 +1602,24 @@ ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen
|
||||
|
||||
UserLdapSync: LDAP-Synchronisieren
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen
|
||||
UserHijack: Sitzung übernehmen
|
||||
UserHijack: Sitzung übernehmen
|
||||
|
||||
MailSubjectAllocationStaffRegister allocation@AllocationName: Sie können nun Kurse für die Zentralameldung „#{allocation}“ registrieren
|
||||
MailAllocationStaffRegisterNewCourse: Sie können auf der unten aufgeführten Seite neue Kurse in Uni2work anlegen. Hierbei haben Sie die Möglichkeit anzugeben, dass der Kurs an der Zentralanmeldung teilnimmt.
|
||||
MailAllocationStaffRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Kurse, die an der Zentralanmeldung teilnehmen, bis #{deadline} eingetragen sein müssen.
|
||||
|
||||
MailSubjectAllocationRegister allocation@AllocationName: Sie können sich nun für Kurse der Zentralameldung „#{allocation}“ bewerben
|
||||
MailAllocationRegister: Sie können sich, auf der unten aufgeführten Seite, für alle Kurse der Zentralanmeldung jeweils einzeln bewerben.
|
||||
MailAllocationRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Bewerbungen bis #{deadline} eingegangen sein müssen.
|
||||
|
||||
MailSubjectAllocationAllocation allocation@AllocationName: Sie können nun Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ bewerten
|
||||
MailAllocationAllocation: Sie können nun auf den unten aufgeführten Seiten Bewerbungen, die im Rahmen der Zentralanmeldung an ihre Kurse gestellt wurden, bewerten. Die Bewertungen werden bei der Vergabe der Plätze berücksichtigt.
|
||||
MailAllocationApplicationsMayChange deadline@Text: Bitte beachten Sie, dass Studierende noch bis #{deadline} Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden.
|
||||
MailAllocationAllocationDeadline deadline@Text: Bitte beachten Sie, dass alle Bewertungen bis #{deadline} erfolgt sein müssen.
|
||||
|
||||
MailSubjectAllocationUnratedApplications allocation@AllocationName: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ aus
|
||||
MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die noch nicht bewertet wurden.
|
||||
|
||||
MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert
|
||||
MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden.
|
||||
MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet.
|
||||
@ -13,18 +13,18 @@ getCAEditR = postCAEditR
|
||||
postCAEditR tid ssh csh cID = do
|
||||
uid <- requireAuthId
|
||||
appId <- decrypt cID
|
||||
(mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
|
||||
(mAlloc, Entity cid Course{..}, CourseApplication{..}, User{..}) <- runDB $ do
|
||||
course <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
app <- get404 appId
|
||||
mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
|
||||
appUser <- get404 $ courseApplicationUser app
|
||||
isAdmin <- case mAlloc of
|
||||
Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin]
|
||||
Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin]
|
||||
return (mAlloc, course, app, isAdmin, appUser)
|
||||
return (mAlloc, course, app, appUser)
|
||||
|
||||
isAdmin <- case mAlloc of
|
||||
Just alloc -> hasWriteAccessTo $ SchoolR (alloc ^. _entityVal . _allocationSchool) SchoolEditR
|
||||
Nothing -> hasWriteAccessTo $ SchoolR (course ^. _entityVal . _courseSchool ) SchoolEditR
|
||||
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||
afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR -- TODO: Wrong.
|
||||
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
|
||||
let afMode = ApplicationFormMode
|
||||
@ -33,7 +33,7 @@ postCAEditR tid ssh csh cID = do
|
||||
, afmLecturer
|
||||
}
|
||||
|
||||
(ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
||||
(ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) courseApplicationUser cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
||||
| uid == courseApplicationUser
|
||||
, Just (Entity _ Allocation{..}) <- mAlloc
|
||||
-> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID
|
||||
|
||||
@ -35,6 +35,7 @@ data NotificationTriggerKind
|
||||
| NTKCourseParticipant
|
||||
| NTKExamParticipant
|
||||
| NTKCorrector
|
||||
| NTKAllocationStaff
|
||||
| NTKFunctionary SchoolFunction
|
||||
deriving (Eq, Ord, Generic, Typeable)
|
||||
deriveFinite ''NotificationTriggerKind
|
||||
@ -45,6 +46,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where
|
||||
NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
|
||||
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
|
||||
NTKCorrector -> mr MsgNotificationTriggerKindCorrector
|
||||
NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
|
||||
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
|
||||
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
|
||||
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
|
||||
@ -149,17 +151,22 @@ notificationForm template = wFormToAForm $ do
|
||||
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
|
||||
|
||||
ntSection = \case
|
||||
NTSubmissionRatedGraded -> Just NTKCourseParticipant
|
||||
NTSubmissionRated -> Just NTKCourseParticipant
|
||||
NTSheetActive -> Just NTKCourseParticipant
|
||||
NTSheetSoonInactive -> Just NTKCourseParticipant
|
||||
NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTCorrectionsAssigned -> Just NTKCorrector
|
||||
NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTUserRightsUpdate -> Just NTKAll
|
||||
NTUserAuthModeUpdate -> Just NTKAll
|
||||
NTExamResult -> Just NTKExamParticipant
|
||||
-- _other -> Nothing
|
||||
NTSubmissionRatedGraded -> Just NTKCourseParticipant
|
||||
NTSubmissionRated -> Just NTKCourseParticipant
|
||||
NTSheetActive -> Just NTKCourseParticipant
|
||||
NTSheetSoonInactive -> Just NTKCourseParticipant
|
||||
NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTCorrectionsAssigned -> Just NTKCorrector
|
||||
NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTUserRightsUpdate -> Just NTKAll
|
||||
NTUserAuthModeUpdate -> Just NTKAll
|
||||
NTExamResult -> Just NTKExamParticipant
|
||||
NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTAllocationAllocation -> Just NTKAllocationStaff
|
||||
NTAllocationRegister -> Just NTKAll
|
||||
NTAllocationOutdatedRatings -> Just NTKAllocationStaff
|
||||
NTAllocationUnratedApplications -> Just NTKAllocationStaff
|
||||
-- _other -> Nothing
|
||||
|
||||
forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
|
||||
|
||||
|
||||
@ -57,7 +57,7 @@ import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup, Min(..), Max(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
|
||||
import Numeric.Natural as Import (Natural)
|
||||
|
||||
@ -224,3 +224,57 @@ determineCrontab = execWriterT $ do
|
||||
_other -> return ()
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs
|
||||
|
||||
let
|
||||
allocationJobs (Entity nAllocation Allocation{..}) = do
|
||||
whenIsJust allocationStaffRegisterFrom $ \staffRegisterFrom ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationStaffRegister{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffRegisterFrom
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffRegisterTo
|
||||
}
|
||||
whenIsJust allocationRegisterFrom $ \registerFrom ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationRegister{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerFrom
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationRegisterTo
|
||||
}
|
||||
whenIsJust allocationStaffAllocationFrom $ \allocationFrom ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationAllocation{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ allocationFrom
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
||||
}
|
||||
case allocationRegisterTo of
|
||||
Just registerTo
|
||||
| maybe True (> registerTo) allocationStaffAllocationTo
|
||||
-> do
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationUnratedApplications{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
||||
}
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationOutdatedRatings{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) allocationStaffAllocationTo
|
||||
}
|
||||
_other
|
||||
-> return ()
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs
|
||||
|
||||
@ -9,6 +9,7 @@ import Data.List (nub)
|
||||
import Jobs.Types
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Utils.Sql
|
||||
import Jobs.Queue
|
||||
|
||||
@ -80,6 +81,86 @@ determineNotificationCandidates notif@NotificationExamResult{..} = do
|
||||
whenIsJust lastExec $ \lastExec' ->
|
||||
E.where_ $ examResult E.^. ExamResultLastChanged E.>. E.val lastExec'
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationStaffRegister{..} = do
|
||||
Allocation{..} <- getJust nAllocation
|
||||
E.select . E.from $ \(user `E.InnerJoin` userFunction) -> do
|
||||
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
|
||||
E.&&. userFunction E.^. UserFunctionSchool E.==. E.val allocationSchool
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer
|
||||
|
||||
E.where_ . E.exists . E.from $ \userSchool ->
|
||||
E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId
|
||||
E.&&. userSchool E.^. UserSchoolSchool E.==. E.val allocationSchool
|
||||
E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut)
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
E.where_ . E.exists . E.from $ \allocationCourse ->
|
||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationAllocation{..} =
|
||||
E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
|
||||
E.&&. E.not_ (E.isNothing $ application E.^. CourseApplicationRatingTime)
|
||||
|
||||
E.where_ . E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
|
||||
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationUnratedApplications{..} =
|
||||
E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
|
||||
E.where_ . E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
|
||||
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
|
||||
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationRegister{..} = do
|
||||
Allocation{..} <- getJust nAllocation
|
||||
E.select . E.from $ \user -> do
|
||||
E.where_ . E.exists . E.from $ \userSchool ->
|
||||
E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId
|
||||
E.&&. userSchool E.^. UserSchoolSchool E.==. E.val allocationSchool
|
||||
E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut)
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
|
||||
|
||||
return user
|
||||
determineNotificationCandidates NotificationAllocationOutdatedRatings{..} =
|
||||
E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||
|
||||
E.where_ . E.exists . E.from $ \application ->
|
||||
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
|
||||
E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
|
||||
|
||||
return user
|
||||
|
||||
|
||||
classifyNotification :: Notification -> DB NotificationTrigger
|
||||
@ -96,3 +177,8 @@ classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrecti
|
||||
classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate
|
||||
classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate
|
||||
classifyNotification NotificationExamResult{} = return NTExamResult
|
||||
classifyNotification NotificationAllocationStaffRegister{} = return NTAllocationStaffRegister
|
||||
classifyNotification NotificationAllocationAllocation{} = return NTAllocationAllocation
|
||||
classifyNotification NotificationAllocationRegister{} = return NTAllocationRegister
|
||||
classifyNotification NotificationAllocationOutdatedRatings{} = return NTAllocationOutdatedRatings
|
||||
classifyNotification NotificationAllocationUnratedApplications{} = return NTAllocationUnratedApplications
|
||||
|
||||
@ -15,6 +15,7 @@ import Jobs.Handler.SendNotification.CorrectionsNotDistributed
|
||||
import Jobs.Handler.SendNotification.UserRightsUpdate
|
||||
import Jobs.Handler.SendNotification.UserAuthModeUpdate
|
||||
import Jobs.Handler.SendNotification.ExamResult
|
||||
import Jobs.Handler.SendNotification.Allocation
|
||||
|
||||
|
||||
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
|
||||
|
||||
159
src/Jobs/Handler/SendNotification/Allocation.hs
Normal file
159
src/Jobs/Handler/SendNotification/Allocation.hs
Normal file
@ -0,0 +1,159 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
|
||||
|
||||
module Jobs.Handler.SendNotification.Allocation
|
||||
( dispatchNotificationAllocationStaffRegister
|
||||
, dispatchNotificationAllocationRegister
|
||||
, dispatchNotificationAllocationAllocation
|
||||
, dispatchNotificationAllocationUnratedApplications
|
||||
, dispatchNotificationAllocationOutdatedRatings
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do
|
||||
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
registerDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffRegisterTo
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationStaffRegister.hamlet")
|
||||
|
||||
dispatchNotificationAllocationRegister :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecipient $ do
|
||||
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationRegister allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
registerDeadline <- traverse (formatTime SelFormatDateTime) allocationRegisterTo
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationRegister.hamlet")
|
||||
|
||||
dispatchNotificationAllocationAllocation :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationAllocation nAllocation jRecipient = do
|
||||
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
|
||||
allocation <- getJust nAllocation
|
||||
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
return ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseName
|
||||
)
|
||||
let courses' = courses
|
||||
& over (traverse . _1) E.unValue
|
||||
& over (traverse . _2) E.unValue
|
||||
& over (traverse . _3) E.unValue
|
||||
& over (traverse . _4) E.unValue
|
||||
return (allocation, courses')
|
||||
|
||||
unless (null courses) . userMailT jRecipient $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationAllocation allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo
|
||||
registerDeadline <- traverse (formatTime SelFormatDateTime) $ assertM (> now) allocationRegisterTo
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationAllocation.hamlet")
|
||||
|
||||
dispatchNotificationAllocationUnratedApplications :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
|
||||
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
|
||||
allocation <- getJust nAllocation
|
||||
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
|
||||
let
|
||||
unratedAppCount :: E.SqlExpr (E.Value Natural)
|
||||
unratedAppCount = E.sub_select . E.from $ \application -> do
|
||||
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
|
||||
return E.countRows
|
||||
|
||||
return ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseName
|
||||
, unratedAppCount
|
||||
)
|
||||
let courses' = courses
|
||||
& over (traverse . _1) E.unValue
|
||||
& over (traverse . _2) E.unValue
|
||||
& over (traverse . _3) E.unValue
|
||||
& over (traverse . _4) E.unValue
|
||||
& over (traverse . _5) E.unValue
|
||||
& filter ((> 0) . view _5)
|
||||
return (allocation, courses')
|
||||
|
||||
|
||||
unless (null courses) . userMailT jRecipient $ do
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationUnratedApplications allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationUnratedApplications.hamlet")
|
||||
|
||||
dispatchNotificationAllocationOutdatedRatings :: AllocationId -> UserId -> Handler ()
|
||||
dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
|
||||
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
|
||||
allocation <- getJust nAllocation
|
||||
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. E.val jRecipient
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||
|
||||
let
|
||||
outdatedRatingsAppCount :: E.SqlExpr (E.Value Natural)
|
||||
outdatedRatingsAppCount = E.sub_select . E.from $ \application -> do
|
||||
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||
E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
|
||||
return E.countRows
|
||||
|
||||
return ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseName
|
||||
, outdatedRatingsAppCount
|
||||
)
|
||||
let courses' = courses
|
||||
& over (traverse . _1) E.unValue
|
||||
& over (traverse . _2) E.unValue
|
||||
& over (traverse . _3) E.unValue
|
||||
& over (traverse . _4) E.unValue
|
||||
& over (traverse . _5) E.unValue
|
||||
& filter ((> 0) . view _5)
|
||||
return (allocation, courses')
|
||||
|
||||
|
||||
unless (null courses) . userMailT jRecipient $ do
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectAllocationOutdatedRatings allocationName
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
allocationDeadline <- traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo
|
||||
addAlternatives $
|
||||
providePreferredAlternative $(ihamletFile "templates/mail/allocationOutdatedRatings.hamlet")
|
||||
|
||||
@ -67,6 +67,11 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
|
||||
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
|
||||
| NotificationExamResult { nExam :: ExamId }
|
||||
| NotificationAllocationStaffRegister { nAllocation :: AllocationId }
|
||||
| NotificationAllocationRegister { nAllocation :: AllocationId }
|
||||
| NotificationAllocationAllocation { nAllocation :: AllocationId }
|
||||
| NotificationAllocationUnratedApplications { nAllocation :: AllocationId }
|
||||
| NotificationAllocationOutdatedRatings { nAllocation :: AllocationId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Hashable Job
|
||||
|
||||
@ -14,6 +14,7 @@ import Import.NoModel
|
||||
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
@ -31,6 +32,11 @@ data NotificationTrigger
|
||||
| NTUserRightsUpdate
|
||||
| NTUserAuthModeUpdate
|
||||
| NTExamResult
|
||||
| NTAllocationStaffRegister
|
||||
| NTAllocationAllocation
|
||||
| NTAllocationRegister
|
||||
| NTAllocationOutdatedRatings
|
||||
| NTAllocationUnratedApplications
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Universe NotificationTrigger
|
||||
@ -54,17 +60,12 @@ newtype NotificationSettings = NotificationSettings { notificationAllowed :: Not
|
||||
deriving newtype (Eq, Ord, Read, Show)
|
||||
|
||||
instance Default NotificationSettings where
|
||||
def = NotificationSettings $ \case
|
||||
NTSubmissionRatedGraded -> True
|
||||
NTSubmissionRated -> True
|
||||
NTSheetActive -> True
|
||||
NTSheetSoonInactive -> False
|
||||
NTSheetInactive -> True
|
||||
NTCorrectionsAssigned -> True
|
||||
NTCorrectionsNotDistributed -> True
|
||||
NTUserRightsUpdate -> True
|
||||
NTUserAuthModeUpdate -> True
|
||||
NTExamResult -> True
|
||||
def = NotificationSettings $ not . flip HashSet.member defaultOff
|
||||
where
|
||||
defaultOff :: HashSet NotificationTrigger
|
||||
defaultOff = HashSet.fromList
|
||||
[ NTSheetSoonInactive
|
||||
]
|
||||
|
||||
instance ToJSON NotificationSettings where
|
||||
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
|
||||
|
||||
32
templates/mail/allocationAllocation.hamlet
Normal file
32
templates/mail/allocationAllocation.hamlet
Normal file
@ -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 $ MsgMailSubjectAllocationAllocation allocationName}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationAllocation}
|
||||
<ul>
|
||||
$forall (tid, ssh, csh, cName) <- courses
|
||||
<li>
|
||||
<a href=@{CourseR tid ssh csh CApplicationsR}>
|
||||
#{cName}
|
||||
|
||||
$maybe until <- registerDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationApplicationsMayChange until}
|
||||
|
||||
$maybe until <- allocationDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationAllocationDeadline until}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
37
templates/mail/allocationOutdatedRatings.hamlet
Normal file
37
templates/mail/allocationOutdatedRatings.hamlet
Normal file
@ -0,0 +1,37 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
|
||||
.emph {
|
||||
font-style: italic;
|
||||
font-weight: 600;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
_{SomeMessage $ MsgMailSubjectAllocationOutdatedRatings allocationName}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationOutdatedRatings}
|
||||
<ul>
|
||||
$forall (tid, ssh, csh, cName, numOutdated) <- courses
|
||||
<li>
|
||||
<a href=@{CourseR tid ssh csh CApplicationsR}>
|
||||
#{cName}
|
||||
\ (#{tshow numOutdated})
|
||||
|
||||
<p .emph>
|
||||
_{SomeMessage MsgMailAllocationOutdatedRatingsWarning}
|
||||
|
||||
$maybe until <- allocationDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationAllocationDeadline until}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
26
templates/mail/allocationRegister.hamlet
Normal file
26
templates/mail/allocationRegister.hamlet
Normal file
@ -0,0 +1,26 @@
|
||||
$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 $ MsgMailSubjectAllocationRegister allocationName}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationRegister}
|
||||
<br>
|
||||
<a href=@{AllocationR allocationTerm allocationSchool allocationShorthand AShowR}>
|
||||
#{allocationName}
|
||||
|
||||
$maybe until <- registerDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationRegisterDeadline until}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
26
templates/mail/allocationStaffRegister.hamlet
Normal file
26
templates/mail/allocationStaffRegister.hamlet
Normal file
@ -0,0 +1,26 @@
|
||||
$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 $ MsgMailSubjectAllocationStaffRegister allocationName}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationStaffRegisterNewCourse}
|
||||
<br>
|
||||
<a href=@{CourseNewR}>
|
||||
_{SomeMessage MsgMenuCourseNew}
|
||||
|
||||
$maybe until <- registerDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationStaffRegisterDeadline until}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
29
templates/mail/allocationUnratedApplications.hamlet
Normal file
29
templates/mail/allocationUnratedApplications.hamlet
Normal file
@ -0,0 +1,29 @@
|
||||
$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 $ MsgMailSubjectAllocationUnratedApplications allocationName}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationUnratedApplications}
|
||||
<ul>
|
||||
$forall (tid, ssh, csh, cName, numUnrated) <- courses
|
||||
<li>
|
||||
<a href=@{CourseR tid ssh csh CApplicationsR}>
|
||||
#{cName}
|
||||
\ (#{tshow numUnrated})
|
||||
|
||||
$maybe until <- allocationDeadline
|
||||
<p>
|
||||
_{SomeMessage $ MsgMailAllocationAllocationDeadline until}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
Loading…
Reference in New Issue
Block a user