fix(lms): send e-learning failed qualification only once

src/Jobs/Handler/LMS.hs

@@ -222,14 +222,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
           let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
               saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
                             && qualificationUserLastRefresh <= utctDay lmsUserStarted
-              newStatus   = LmsSuccess lmsResultSuccess
+              newStatus   = Just $ LmsSuccess lmsResultSuccess              
               -- newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
-          note <- if saneDate && isLmsSuccess newStatus
+          note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
             then do
-              _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked is unaffected
+              _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected
               -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
               update luid 
-                [ LmsUserStatus   =. Just newStatus
+                [ LmsUserStatus   =. newStatus
                 , LmsUserReceived =. Just lmsResultTimestamp
                 ]                          
               -- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
@@ -277,32 +277,35 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
           | otherwise -> return ()                     -- users likely not yet started
 
         (Entity luid luser, Just (Entity lulid lulist)) -> do
+          let lReceived = lmsUserlistTimestamp lulist
+              lmsMsgDay = utctDay lReceived
+          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
+          -- $logInfoS "LmsUserlist" $ tshow lulist
+
           when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
             queueDBJob JobSendNotification
               { jRecipient    = lmsUserUser luser
               , jNotification = NotificationQualificationRenewal { nQualification = qid }
               }
-          let lReceived = lmsUserlistTimestamp lulist
+          
-              isBlocked = lmsUserlistFailed    lulist
+          let isBlocked = lmsUserlistFailed lulist
-          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotfied is only updated upon sending notifications
+              oldStatus = lmsUserStatus luser
-          $logInfoS "LmsUserlist" $ tshow lulist
+              newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked
-          when isBlocked $ do
+              updateStatus = replaceLmsStatus oldStatus newStatus 
-            let blockedDay = utctDay lReceived
+          when updateStatus $ do
-                newStatus  = LmsBlocked blockedDay
-                oldStatus  = lmsUserStatus luser
             audit TransactionLmsBlocked
               { transactionQualification = qid
               , transactionLmsIdent      = lmsUserIdent luser
-              , transactionLmsDay        = blockedDay
+              , transactionLmsDay        = lmsMsgDay
               , transactionLmsUser       = Just $ lmsUserUser luser
               , transactionNote          = Just $ "Old status was " <> tshow oldStatus
               , transactionReceived      = lReceived
               }
-            update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
+            update luid [LmsUserStatus =. newStatus]
-            void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay                                                                        
+            void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay
             queueDBJob JobSendNotification
               { jRecipient    = lmsUserUser luser
-              , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }
+              , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay }
               }
 
           delete lulid

src/Model/Types/Lms.hs

@@ -55,6 +55,18 @@ isLmsSuccess :: LmsStatus -> Bool
 isLmsSuccess LmsSuccess{} = True 
 isLmsSuccess _other       = False
 
+isLmsExpired :: LmsStatus -> Bool 
+isLmsExpired LmsExpired{} = True 
+isLmsExpired _other       = False
+
+-- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten
+replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool
+replaceLmsStatus _ Nothing = False
+replaceLmsStatus Nothing _ = True
+replaceLmsStatus (Just LmsSuccess{}) _  = False
+replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat
+replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat
+
 makeLenses_ ''LmsStatus
 
 -- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec