fradrive/src/Jobs/Handler/QueueNotification.hs
2020-08-27 22:58:28 +02:00

318 lines
21 KiB
Haskell

module Jobs.Handler.QueueNotification
( dispatchJobQueueNotification
) where
import Import
import Jobs.Types
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Jobs.Queue
import qualified Data.Set as Set
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', Entity _ User{userNotificationSettings}) -> notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', Entity uid _) -> JobSendNotification uid notification')
.| sinkDBJobs
determineNotificationCandidates :: ConduitT Notification (Notification, Entity User) DB ()
determineNotificationCandidates = awaitForever $ \notif -> do
let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Entity User) DB ()
withNotif c = toProducer c .| C.map (notif, )
-- | 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 ()
separateTargets mkNotif' c = toProducer c .| go Nothing Set.empty
where go Nothing _ = do
next <- await
case next of
Nothing -> return ()
Just (uent, E.Value t) -> go (Just uent) $ Set.singleton t
go (Just uent) ts = do
next <- await
case next of
Nothing -> yield (mkNotif' ts, 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
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 . nub $ 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
NotificationAllocationStaffRegister{..}
-> separateTargets NotificationAllocationStaffRegister . E.selectSource . E.from $ \(user `E.InnerJoin` userFunction `E.InnerJoin` allocation) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId, E.asc $ allocation E.^. AllocationId] $ do
E.on $ userFunction E.^. UserFunctionSchool E.==. allocation E.^. AllocationSchool
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer
E.&&. allocation E.^. AllocationId `E.in_` E.valList (Set.toList nAllocations)
E.where_ . E.exists . E.from $ \userSchool ->
E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId
E.&&. userSchool E.^. UserSchoolSchool E.==. allocation E.^. 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.==. allocation E.^. AllocationId
return (user, allocation E.^. AllocationId)
NotificationAllocationRegister{..}
-> separateTargets NotificationAllocationRegister . E.selectSource . E.from $ \(user `E.InnerJoin` allocation) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId, E.asc $ allocation E.^. AllocationId] $ do
E.on E.true
E.where_ $ allocation E.^. AllocationId `E.in_` E.valList (Set.toList nAllocations)
E.where_ . E.exists . E.from $ \userSchool ->
E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId
E.&&. userSchool E.^. UserSchoolSchool E.==. allocation E.^. AllocationSchool
E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut)
E.where_ . E.not_ . E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
return (user, allocation E.^. AllocationId)
NotificationAllocationAllocation{..}
-> separateTargets NotificationAllocationAllocation . E.selectSource . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId, E.asc $ allocationCourse E.^. AllocationCourseAllocation] $ do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ allocationCourse E.^. AllocationCourseAllocation `E.in_` E.valList (Set.toList nAllocations)
E.where_ . E.not_ . E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
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.just (allocationCourse E.^. AllocationCourseAllocation)
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
return (user, allocationCourse E.^. AllocationCourseAllocation)
NotificationAllocationUnratedApplications{..}
-> separateTargets NotificationAllocationUnratedApplications . E.selectSource . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId, E.asc $ allocationCourse E.^. AllocationCourseAllocation] $ do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ allocationCourse E.^. AllocationCourseAllocation `E.in_` E.valList (Set.toList nAllocations)
E.where_ . E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId
E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
return (user, allocationCourse E.^. AllocationCourseAllocation)
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
NotificationAllocationResults{..}
-> do
lastExec <- lift . fmap (fmap $ cronLastExecTime . entityVal) . getBy . UniqueCronLastExec . toJSON $ JobQueueNotification notif
withNotif . E.selectSource . E.from $ \user -> do
let isStudent = E.exists . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation)
E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
isLecturer = E.exists . E.from $ \(lecturer `E.InnerJoin` allocationCourse) ->
E.on $ lecturer E.^. LecturerCourse E.==. allocationCourse E.^. AllocationCourseCourse
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId
wasAllocated t = E.exists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
hasAllocations t = E.exists . E.from $ \(lecturer `E.InnerJoin` participant) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.&&. lecturer E.^. LecturerCourse E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
case lastExec of
Nothing -> E.where_ $ isStudent E.||. isLecturer
Just t -> E.where_ $ wasAllocated t E.||. hasAllocations t
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
classifyNotification :: Notification -> DB NotificationTrigger
classifyNotification NotificationSubmissionRated{..} = do
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
return $ case sheetType of
NotGraded -> NTSubmissionRated
_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 NotificationAllocationStaffRegister{} = return NTAllocationStaffRegister
classifyNotification NotificationAllocationAllocation{} = return NTAllocationAllocation
classifyNotification NotificationAllocationRegister{} = return NTAllocationRegister
classifyNotification NotificationAllocationUnratedApplications{} = return NTAllocationUnratedApplications
classifyNotification NotificationExamOfficeExamResults{} = return NTExamOfficeExamResults
classifyNotification NotificationExamOfficeExamResultsChanged{} = return NTExamOfficeExamResultsChanged
classifyNotification NotificationExamOfficeExternalExamResults{} = return NTExamOfficeExamResults
classifyNotification NotificationAllocationResults{} = return NTAllocationResults
classifyNotification NotificationCourseRegistered{} = return NTCourseRegistered
classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited
classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated
classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted