feat(allocations): notifications

This commit is contained in:
Gregor Kleen 2019-09-05 08:37:56 +02:00
parent 454a0ff469
commit 6d52ed5c4c
15 changed files with 520 additions and 31 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

View 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}

View 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}

View 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}

View 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}

View 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}