210 lines
14 KiB
Haskell
210 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Jobs.Handler.QueueNotification
|
|
( dispatchJobQueueNotification
|
|
, classifyNotification
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Jobs.Types
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import Jobs.Queue
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Handler.Utils.Profile (pickValidUserEmail')
|
|
import Handler.Utils.ExamOffice.Exam
|
|
import Handler.Utils.ExamOffice.ExternalExam
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
|
|
dispatchJobQueueNotification jNotification = JobHandlerAtomic $
|
|
runConduit $ yield jNotification
|
|
.| transPipe (hoist lift) determineNotificationCandidates
|
|
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) ->
|
|
and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $
|
|
or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
|
|
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
|
|
.| sinkDBJobs
|
|
|
|
|
|
determineNotificationCandidates :: ConduitT Notification (Notification, Bool, Entity User) DB ()
|
|
determineNotificationCandidates = awaitForever $ \notif -> do
|
|
let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
|
|
withNotif c = toProducer c .| C.map (notif, False, )
|
|
|
|
case notif of
|
|
NotificationSubmissionRated{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` submissionUser) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
|
return user
|
|
NotificationSheetActive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationSheetHint{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationSheetSolution{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationSheetSoonInactive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationSheetInactive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
|
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationCorrectionsAssigned{..}
|
|
-> withNotif $ selectSource [UserId ==. nUser] []
|
|
NotificationCorrectionsNotDistributed{nSheet}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
|
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
|
return user
|
|
NotificationUserRightsUpdate{..}
|
|
-> do
|
|
-- always send to affected user
|
|
affectedUser <- lift $ selectList [UserId ==. nUser] []
|
|
-- send to same-school admins only if there was an update
|
|
currentAdminSchools <- lift $ setOf (folded . _entityVal . _userFunctionSchool) <$> selectList [UserFunctionUser ==. nUser, UserFunctionFunction ==. SchoolAdmin] []
|
|
let oldAdminSchools = setOf (folded . filtered ((== SchoolAdmin) . view _1) . _2 . from _SchoolId) nOriginalRights
|
|
newAdminSchools = currentAdminSchools `Set.difference` oldAdminSchools
|
|
affectedAdmins <- lift . E.select . E.from $ \(user `E.InnerJoin` admin) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ admin E.^. UserFunctionUser E.==. user E.^. UserId
|
|
E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools)
|
|
E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
return user
|
|
withNotif . yieldMany . nubOrd $ affectedUser <> affectedAdmins
|
|
NotificationUserSystemFunctionsUpdate{..}
|
|
-> withNotif $ selectSource [UserId ==. nUser] []
|
|
NotificationUserAuthModeUpdate{..}
|
|
-> withNotif $ selectSource [UserId ==. nUser] []
|
|
NotificationExamRegistrationActive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(exam `E.InnerJoin` courseParticipant `E.InnerJoin` user) -> do
|
|
E.on $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. exam E.^. ExamCourse
|
|
E.where_ $ exam E.^. ExamId E.==. E.val nExam
|
|
E.where_ . E.not_ . E.exists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return user
|
|
NotificationExamRegistrationSoonInactive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(exam `E.InnerJoin` courseParticipant `E.InnerJoin` user) -> do
|
|
E.on $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. exam E.^. ExamCourse
|
|
E.where_ $ exam E.^. ExamId E.==. E.val nExam
|
|
E.where_ . E.not_ . E.exists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return user
|
|
NotificationExamDeregistrationSoonInactive{..}
|
|
-> withNotif . E.selectSource . E.from $ \(examRegistration `E.InnerJoin` user) -> do
|
|
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
|
|
return user
|
|
NotificationExamResult{..}
|
|
-> do
|
|
lastExec <- lift . fmap (fmap $ cronLastExecTime . entityVal) . getBy . UniqueCronLastExec . toJSON $ JobQueueNotification notif
|
|
withNotif . E.selectSource . E.from $ \(examResult `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
|
E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
|
|
whenIsJust lastExec $ \lastExec' ->
|
|
E.where_ $ examResult E.^. ExamResultLastChanged E.>. E.val lastExec'
|
|
return user
|
|
NotificationExamOfficeExamResults{..}
|
|
-> withNotif . E.selectSource . E.from $ \user -> do
|
|
E.where_ . E.exists . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
|
|
E.where_ $ examOfficeExamResultAuth (user E.^. UserId) examResult
|
|
return user
|
|
NotificationExamOfficeExamResultsChanged{..}
|
|
-> withNotif . E.selectSource . E.from $ \user -> do
|
|
E.where_ . E.exists . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultId `E.in_` E.valList (Set.toList nExamResults)
|
|
E.where_ $ examOfficeExamResultAuth (user E.^. UserId) examResult
|
|
return user
|
|
NotificationExamOfficeExternalExamResults{..}
|
|
-> withNotif . E.selectSource . E.from $ \user -> do
|
|
E.where_ . E.exists . E.from $ \externalExamResult -> do
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
|
|
E.where_ $ examOfficeExternalExamResultAuth (user E.^. UserId) externalExamResult
|
|
return user
|
|
NotificationCourseRegistered{..}
|
|
-> withNotif . yieldMMany $ getEntity nUser
|
|
NotificationSubmissionEdited{..}
|
|
-> withNotif . E.selectSource . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
|
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
|
E.&&. user E.^. UserId E.!=. E.val nInitiator
|
|
return user
|
|
NotificationSubmissionUserCreated{..}
|
|
-> withNotif . yieldMMany $ getEntity nUser
|
|
NotificationSubmissionUserDeleted{..}
|
|
-> withNotif . yieldMMany $ getEntity nUser
|
|
NotificationQualificationExpiry{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
|
NotificationQualificationExpired{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
|
NotificationQualificationRenewal{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
|
|
|
|
|
|
|
classifyNotification :: Notification -> DB NotificationTrigger
|
|
classifyNotification NotificationSubmissionRated{..} =
|
|
maybeM (return NTSubmissionRatedGraded) (fmap aux . belongsToJust submissionSheet) (get nSubmission)
|
|
where
|
|
aux Sheet{sheetType=NotGraded} = NTSubmissionRated
|
|
aux _other = NTSubmissionRatedGraded
|
|
classifyNotification NotificationSheetActive{} = return NTSheetActive
|
|
classifyNotification NotificationSheetHint{} = return NTSheetHint
|
|
classifyNotification NotificationSheetSolution{} = return NTSheetSolution
|
|
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
|
|
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
|
|
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
|
|
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
|
|
classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate
|
|
classifyNotification NotificationUserSystemFunctionsUpdate{} = return NTUserRightsUpdate
|
|
classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate
|
|
classifyNotification NotificationExamRegistrationActive{} = return NTExamRegistrationActive
|
|
classifyNotification NotificationExamRegistrationSoonInactive{} = return NTExamRegistrationSoonInactive
|
|
classifyNotification NotificationExamDeregistrationSoonInactive{} = return NTExamDeregistrationSoonInactive
|
|
classifyNotification NotificationExamResult{} = return NTExamResult
|
|
classifyNotification NotificationExamOfficeExamResults{} = return NTExamOfficeExamResults
|
|
classifyNotification NotificationExamOfficeExamResultsChanged{} = return NTExamOfficeExamResultsChanged
|
|
classifyNotification NotificationExamOfficeExternalExamResults{} = return NTExamOfficeExamResults
|
|
classifyNotification NotificationCourseRegistered{} = return NTCourseRegistered
|
|
classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited
|
|
classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated
|
|
classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted
|
|
classifyNotification NotificationQualificationExpiry{} = return NTQualificationExpiry
|
|
classifyNotification NotificationQualificationExpired{} = return NTQualificationExpiry
|
|
classifyNotification NotificationQualificationRenewal{nReminder}
|
|
| nReminder = return NTQualificationReminder
|
|
| otherwise = return NTQualificationExpiry
|