chore(lms): job dequeue implemented, deleting missing still

models/lms.model

@@ -1,4 +1,5 @@
 Qualification
+  -- INVARIANT: 2*refreshWithin < validDuration 
   school              SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen
   shorthand           (CI Text)
   name                (CI Text)
@@ -85,7 +86,7 @@ QualificationUser
   --     - move row to LmsAudit
   --
   -- 7. Daily Job: dequeue LMS Users
-  --     - 
+  --     - renew qualification, if passed
   --     - remove from LmsUser after audit Period has passed
 
 LmsUser

src/Database/Esqueleto/Utils.hs

@@ -86,6 +86,10 @@ true  = E.val True
 false :: E.SqlExpr (E.Value Bool)
 false = E.val False
 
+--  Timestamp larger than any other; not sure if this is a good idea to use
+-- infinity :: E.SqlExpr (E.Value UTCTime)
+-- infinity = unsafeSqlValue "'infinity'"
+
 justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
 justVal = E.val . Just
 

src/Handler/LMS.hs

@@ -181,7 +181,7 @@ mkLmsTable (Entity qid quali) = do
           lift $ do
             E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
             E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
-                    E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification   
+                    E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
             E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification                                  
           return (qualUser, user, lmsUser)
         dbtRowKey = queryUser >>> (E.^. UserId)

src/Handler/Qualification.hs

@@ -172,7 +172,7 @@ mkLmsTable (Entity qid quali) = do
           lift $ do
             E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
             E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
-                    E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification   
+                    E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
             E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification                                  
           return (qualUser, user, lmsUser)
         dbtRowKey = queryUser >>> (E.^. UserId)

src/Handler/Utils/DateTime.hs

@@ -14,6 +14,7 @@ module Handler.Utils.DateTime
   , validDateTimeFormats, dateTimeFormatOptions
   , addLocalDays, addDiffDays
   , addOneWeek, addWeeks
+  , fromMonths
   , weeksToAdd
   , setYear, getYear
   , firstDayOfWeekOnAfter
@@ -251,6 +252,14 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
     newDay   = addDays n oldDay
     newLocal = oldLocal { localDay = newDay }
 
+----------------------
+-- CalendarDiffDays --
+----------------------
+
+fromMonths :: Word -> CalendarDiffDays 
+fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth
+-- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
+
 addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime
 addDiffDays = over _utctDay . addGregorianDurationClip
 

src/Jobs/Handler/LMS.hs

@@ -2,6 +2,7 @@
 
 module Jobs.Handler.LMS 
   ( dispatchJobLmsQualifications
+  , dispatchJobQualificationsDequeue
   , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
   , dispatchJobLmsDequeue
   , dispatchJobLmsResults
@@ -17,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 (addDiffDays)
+import Handler.Utils.DateTime (fromMonths)
 import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
 
 
@@ -31,17 +32,18 @@ dispatchJobLmsQualifications = JobHandlerAtomic act
                 E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
                     -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
                 pure $ q E.^. QualificationId
-      forM_ qids $ \(E.unValue -> qid) -> do         
+      forM_ qids $ \(E.unValue -> qid) ->
-        $logInfoS "lms" $ "Start e-learning for qualification " <> tshow qid <> "."        
         queueDBJob $ JobLmsEnqueue qid 
 
 
+-- | enlist expiring qualification holders to e-learning 
+--   NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
 dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsEnqueue qid = JobHandlerAtomic act
-  where 
+  where     
-    -- TODO: get rid of QualificationId Parameter and use a join instead? Fails since addGregorianDurationClip cannot be performed within DB
     -- act :: YesodJobDB UniWorX ()
     act = do
+      $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."        
       quali <- getJust qid -- may throw an error, aborting the job
       case qualificationRefreshWithin quali of 
         Nothing -> return () -- no automatic scheduling for this qid 
@@ -98,12 +100,58 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
                       }
 
 
+dispatchJobQualificationsDequeue :: JobHandler UniWorX
+dispatchJobQualificationsDequeue = JobHandlerAtomic act
+  where
+    act :: YesodJobDB UniWorX ()
+    act = do 
+      qids <- E.select $ do 
+                q <- E.from $ E.table @Qualification
+                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
+                pure $ q E.^. QualificationId
+      forM_ qids $ \(E.unValue -> qid) ->        
+        queueDBJob $ JobLmsEnqueue qid 
+
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsDequeue _qid = 
+dispatchJobLmsDequeue qid = JobHandlerAtomic act
-  -- wenn bestanden: qualification verlängern & LmsIdent löschen
+  -- wenn bestanden: qualification verlängern 
-  -- wenn durchgefallen: LmsIdent löschen
+  -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
-  -- wenn Zeit abgelaufen: LmsIdent löschen 
+  where 
-  error "TODO: lms dequeue stub"
+    act = do
+      $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "."        
+      quali <- getJust qid -- may throw an error, aborting the job
+      case qualificationRefreshWithin quali of 
+        Nothing -> return () -- no automatic scheduling for this qid 
+        (Just renewalPeriod) -> do
+          nowaday <- utctDay <$> liftIO getCurrentTime
+          let renewalDate = addGregorianDurationClip renewalPeriod nowaday
+          
+          -- CONTINUE HERE:
+          --   select users that need renewal due to success
+          --   delete users after audit period has expired            
+
+          renewalUsers <- E.select $ do
+            (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
+                    `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser          E.==. luser E.^. LmsUserUser
+                                            E.&&.  quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
+                            )
+            E.where_ $  E.val qid E.==. quser E.^. QualificationUserQualification 
+                  E.&&. E.val qid E.==. luser E.^. LmsUserQualification             
+                  E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday              -- still valid
+                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate          -- due to renewal
+                  E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success   -- result already known                                 
+            pure (quser, luser)
+          let usr_job (quser, luser) = 
+                let vold   = quser ^. _entityVal . _qualificationUserValidUntil
+                    pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualfication that have infinite validity?!
+                    vnew   = addGregorianDurationClip pmonth vold
+                    lmsstatus = luser ^. _entityVal . _lmsUserStatus
+                in case lmsstatus of 
+                  Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] 
+                  _ -> return ()
+          forM_ renewalUsers usr_job
+
 
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsResults qid = JobHandlerAtomic act 

src/Utils/DateTime.hs

@@ -12,8 +12,7 @@ module Utils.DateTime
   , nominalHour, nominalMinute
   , minNominalYear, avgNominalYear
   , diffMinute, diffHour, diffDay
-  , module Zones
+  , module Zones  
-  , fromMonths
   , day
   ) where
 
@@ -30,7 +29,7 @@ import Data.Time.Format.Instances ()
 import Data.Time.Clock.System (systemEpochDay)
 import qualified Data.Time.Format.ISO8601 as Time
 import qualified Data.Time.Format as Time
-import Data.Time.Calendar (CalendarDiffDays, calendarMonth, scaleCalendarDiffDays)
+-- import Data.Time.Calendar (CalendarDiffDays, calendarMonth, scaleCalendarDiffDays)
 
 import qualified Data.List.NonEmpty as NonEmpty
 
@@ -161,13 +160,6 @@ diffMinute = 60
 diffHour = 3600
 diffDay = 86400
 
-----------------------
--- CalendarDiffDays --
-----------------------
-
-fromMonths :: Word -> CalendarDiffDays 
-fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth
-
 ---------
 -- Day --
 ---------