From 1a4c129bfb08ab9771547c389db11269dc287f3c Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Mon, 19 Sep 2022 12:42:54 +0200
Subject: [PATCH] chore(lms): renew qualification from previous valid until
 value

---
 src/Handler/Utils/DateTime.hs |  5 ++++-
 src/Jobs/Handler/LMS.hs       | 21 ++++++++++++---------
 2 files changed, 16 insertions(+), 10 deletions(-)

diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index ca9778c3b..024bfbf14 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -4,7 +4,7 @@ module Handler.Utils.DateTime
   ( utcToLocalTime, utcToZonedTime
   , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
   , toTimeOfDay
-  , toMidnight, beforeMidnight, toMidday, toMorning
+  , toMidnight, beforeMidnight, toMidday, toMorning, addHours
   , formatDiffDays, formatCalendarDiffDays
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
@@ -74,6 +74,9 @@ toMorning = toTimeOfDay 6 0 0
 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
 toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
 
+addHours :: Integer -> UTCTime -> UTCTime
+addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
+
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime
 
diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs
index f5daef5f6..ba542ef4c 100644
--- a/src/Jobs/Handler/LMS.hs
+++ b/src/Jobs/Handler/LMS.hs
@@ -150,9 +150,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
-      now <- liftIO getCurrentTime
       quali <- getJust qid
-      let renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
+      now <- liftIO getCurrentTime
+      let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
+          renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
                                             (qualificationValidDuration quali)
       -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
       results <- E.select $ do
@@ -171,12 +172,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
           E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result
           E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
         return (quser, luser, lresult)
-      forM_ results $ \(Entity quid QualificationUser{}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
+      forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
         -- three separate DB operations per result is not so nice. All within one transaction though.
-        let saneDate   = lmsResultSuccess `inBetween` (utctDay lmsUserStarted, utctDay now)  
-            newStatus  = LmsSuccess lmsResultSuccess
-            newValidTo = -- addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards 
-                         addMonthsDay renewalMonths lmsResultSuccess               -- renew from completion onwards
+        let lmsUserStartedDay = utctDay lmsUserStarted
+            saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
+                          && qualificationUserLastRefresh <= lmsUserStartedDay
+            newStatus   = LmsSuccess lmsResultSuccess
+            newValidTo  = addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards 
+                          -- addMonthsDay renewalMonths lmsResultSuccess         -- renew from completion onwards
         if saneDate && isLmsSuccess newStatus
           then do
             update quid [ QualificationUserValidUntil  =. newValidTo
@@ -198,7 +201,7 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
   where
     act :: YesodJobDB UniWorX ()
     act = do
-      now <- liftIO getCurrentTime
+      now <- liftIO getCurrentTime      
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
         (luser E.:& lulist) <- E.from $
@@ -210,7 +213,7 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
         return (luser, lulist)
       forM_ results $ \case
         (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser          -- mark all unreported users as ended
+          | isJust    $ lmsUserReceived luser          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
           , isNothing $ lmsUserEnded    luser ->
               update luid [LmsUserEnded =. Just now]
           | otherwise -> return ()                     -- users likely not yet started