fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): renew qualification from previous valid until value

Browse Source
This commit is contained in:
Steffen Jost 2022-09-19 12:42:54 +02:00
parent cba7b4d5c1
commit 1a4c129bfb
2 changed files with 16 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Handler/Utils/DateTime.hs
View File

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

21
src/Jobs/Handler/LMS.hs
View File

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