fix(notifications): direct notifications now respect user triggers

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

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 
+    runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case 
-      [Entity _ UserAvs{userAvsUser=uid}] -> return $ Just uid
+      [Entity _ UserAvs{userAvsUser=uid}] -> Just uid
-      _ -> return Nothing
+      _ -> Nothing
 guessAvsUser someid = do 
   let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard      
   case discernAvsCardPersonalNo someid of    

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

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
+classifyNotification NotificationSubmissionRated{..} = 
-  Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
+    maybeM (return NTSubmissionRatedGraded) (fmap aux . belongsToJust submissionSheet) (get nSubmission)
-  return $ case sheetType of
+  where 
-    NotGraded -> NTSubmissionRated
+    aux Sheet{sheetType=NotGraded} = NTSubmissionRated
-    _other -> NTSubmissionRatedGraded
+    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

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

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

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 
+            in mdTemplating tmpl meta <&> \case 
-                err@Left{} -> pure err
+                err@Left{} -> err
-                Right doc2 -> pure $ Right $ doc1 <> doc2
+                Right doc2 -> Right $ doc1 <> doc2
 
       doc <- foldrM templateCombine (Right mempty) mdls
       -- result <- actRight doc $ pdfLaTeX kind