diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 8f6878216..932384b31 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -12,7 +12,7 @@ module Handler.Utils.DateTime , getTimeLocale, getDateTimeFormat , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions - , addLocalDays, addDiffDays + , addLocalDays, addDiffDays, addMonths , addOneWeek, addWeeks , fromMonths , weeksToAdd @@ -263,6 +263,8 @@ fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime addDiffDays = over _utctDay . addGregorianDurationClip +addMonths :: Word -> UTCTime -> UTCTime +addMonths = addDiffDays . fromMonths weeksToAdd :: UTCTime -> UTCTime -> Integer -- ^ Number of weeks needed to add so that first diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index ee93206d4..30cc3396a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -18,7 +18,7 @@ import qualified Database.Esqueleto.Experimental as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant import qualified Database.Esqueleto.Utils as E -import Handler.Utils.DateTime (fromMonths) +import Handler.Utils.DateTime (fromMonths, addMonths) import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) @@ -45,11 +45,12 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act act = do $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job + now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid (Just renewalPeriod) -> do - nowaday <- utctDay <$> liftIO getCurrentTime - let renewalDate = addGregorianDurationClip renewalPeriod nowaday + let nowaday = utctDay now + renewalDate = addGregorianDurationClip renewalPeriod nowaday renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid @@ -71,7 +72,11 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - + case qualificationAuditDuration quali of + Nothing -> return () -- no automatic removal + (Just auditDuration) -> + let deleteDate = addMonths auditDuration now + in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate] dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act