fix(notifications): direct notifications now respect user triggers

2023-06-28 14:18:39 +00:00 · 2023-06-28 14:18:39 +00:00 · 3e5f271cac
commit 3e5f271cac
parent bbaa42eefa
7 changed files with 39 additions and 19 deletions
--- 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
--- 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    
--- 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 }
            --   }
--- 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
--- 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
--- 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
--- 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