From 3e5f271cacfcc5dbd95aa68a342f56db566f8dee Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 28 Jun 2023 14:18:39 +0000 Subject: [PATCH] fix(notifications): direct notifications now respect user triggers --- src/Handler/LMS.hs | 2 +- src/Handler/Utils/Avs.hs | 6 +++--- src/Jobs/Handler/LMS.hs | 10 +++++----- src/Jobs/Handler/QueueNotification.hs | 15 +++++++++------ src/Jobs/Handler/SendNotification.hs | 15 +++++++++++++++ src/Jobs/Types.hs | 4 +++- src/Utils/Print.hs | 6 +++--- 7 files changed, 39 insertions(+), 19 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d10fbb51e..80eae5b68 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -690,7 +690,7 @@ postLmsR sid qsh = do newPin <- liftIO randomLMSpw update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True] when (isNotifyAct action) $ - queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } + queueDBJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } return $ length okUsers let numSelected = length selectedUsers diffSelected = numSelected - numExaminees diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 386b63a71..60e533856 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -334,9 +334,9 @@ guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidT extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno -> - runDB (selectList [UserAvsNoPerson ==. avsno] []) >>= \case - [Entity _ UserAvs{userAvsUser=uid}] -> return $ Just uid - _ -> return Nothing + runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case + [Entity _ UserAvs{userAvsUser=uid}] -> Just uid + _ -> Nothing guessAvsUser someid = do let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard case discernAvsCardPersonalNo someid of diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index c6dbf3328..933cfa867 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -86,7 +86,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act forM_ reminders $ \case (Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil) | addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil -> - queueDBJob JobSendNotification + queueDBJob JobUserNotification { jRecipient = luser , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True } } @@ -114,7 +114,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else JobSendNotification { jRecipient = uid, jNotification = + else JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) @@ -204,7 +204,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act pure (quser E.^. QualificationUserUser) forM_ notifyInvalidDrivers $ \(E.Value uid) -> - queueDBJob JobSendNotification + queueDBJob JobUserNotification { jRecipient = uid , jNotification = NotificationQualificationExpired { nQualification = qid } } @@ -328,7 +328,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available - queueDBJob JobSendNotification + queueDBJob JobUserNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } @@ -349,7 +349,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act update luid [LmsUserStatus =. newStatus] void $ qualificationUserBlocking qid [lmsUserUser luser] True $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! - -- queueDBJob JobSendNotification + -- queueDBJob JobUserNotification -- { jRecipient = lmsUserUser luser -- , jNotification = NotificationQualificationExpired { nQualification = qid } -- } diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 230ca3ea2..a4a407afa 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -4,6 +4,7 @@ module Jobs.Handler.QueueNotification ( dispatchJobQueueNotification + , classifyNotification ) where import Import @@ -175,11 +176,11 @@ determineNotificationCandidates = awaitForever $ \notif -> do classifyNotification :: Notification -> DB NotificationTrigger -classifyNotification NotificationSubmissionRated{..} = do - Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission - return $ case sheetType of - NotGraded -> NTSubmissionRated - _other -> NTSubmissionRatedGraded +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 @@ -203,4 +204,6 @@ classifyNotification NotificationSubmissionUserCreated{} = return NTSub classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted classifyNotification NotificationQualificationExpiry{} = return NTQualificationExpiry classifyNotification NotificationQualificationExpired{} = return NTQualificationExpiry -classifyNotification NotificationQualificationRenewal{} = return NTQualificationReminder +classifyNotification NotificationQualificationRenewal{nReminder} + | nReminder = return NTQualificationReminder + | otherwise = return NTQualificationExpiry diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 8ed3370d5..198a7f2d8 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -4,6 +4,7 @@ module Jobs.Handler.SendNotification ( dispatchJobSendNotification + , dispatchJobUserNotification ) where import Import @@ -24,7 +25,21 @@ import Jobs.Handler.SendNotification.ExamOffice import Jobs.Handler.SendNotification.CourseRegistered import Jobs.Handler.SendNotification.SubmissionEdited import Jobs.Handler.SendNotification.Qualification +import Jobs.Handler.QueueNotification (classifyNotification) +-- | send a notification directly, ignoring userNotificationSettings, assumed to be checked bt dispatchJobQueueNotification dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ $(dispatchTH ''Notification) jNotification jRecipient + +-- | like `dispatchJobSendNotification` but checks userNotificationSettings first +dispatchJobUserNotification :: UserId -> Notification -> JobHandler UniWorX +dispatchJobUserNotification jRecipient jNotification = JobHandlerException $ do + ok <- runDB $ do + nTrigger <- classifyNotification jNotification + get jRecipient <&> \case + Just User{userNotificationSettings} + -> notificationAllowed userNotificationSettings nTrigger + _ -> False + when ok $ + $(dispatchTH ''Notification) jNotification jRecipient \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index d77ebba09..b19d7353d 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -55,6 +55,7 @@ import Data.Generics.Product.Types (Children, ChGeneric, HasTypesCustom(..)) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobUserNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } | JobQueueNotification { jNotification :: Notification } | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId @@ -153,7 +154,7 @@ data Notification | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } -- NotificationTrigger: NTQualificationExpiry TODO: separate | NotificationQualificationExpired { nQualification :: QualificationId } -- NotificationTrigger: NTQualificationExpiry - | NotificationQualificationRenewal { nQualification :: QualificationId, nReminder :: Bool } -- NotificationTrigger: NTQualificationReminder + | NotificationQualificationRenewal { nQualification :: QualificationId, nReminder :: Bool } -- NotificationTrigger: NTQualificationExpiry/NTQualificationReminder je nach nReminder deriving (Eq, Ord, Show, Read, Generic) instance Hashable Job @@ -331,6 +332,7 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag jobNoQueueSame :: Job -> Maybe JobNoQueueSame jobNoQueueSame = \case JobSendNotification{jNotification} -> notifyNoQueueSame jNotification + JobUserNotification{jNotification} -> notifyNoQueueSame jNotification JobSendPasswordReset{} -> Just JobNoQueueSame JobTruncateTransactionLog{} -> Just JobNoQueueSame JobPruneInvitations{} -> Just JobNoQueueSame diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index cd61e47e7..313ffb333 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -212,9 +212,9 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise ] - in mdTemplating tmpl meta >>= \case - err@Left{} -> pure err - Right doc2 -> pure $ Right $ doc1 <> doc2 + in mdTemplating tmpl meta <&> \case + err@Left{} -> err + Right doc2 -> Right $ doc1 <> doc2 doc <- foldrM templateCombine (Right mempty) mdls -- result <- actRight doc $ pdfLaTeX kind