chore(lms): proper lms dequeueing now implemented; whole process checked

models/lms.model

@@ -1,11 +1,11 @@
 Qualification
-  -- INVARIANT: 2*refreshWithin < validDuration 
+  -- INVARIANT: 2*refreshWithin < validDuration
   school              SchoolId                  --TODO: Ansprechpartner der Schule in Briefe erwähnen
   shorthand           (CI Text)
   name                (CI Text)
   description         StoredMarkup Maybe        -- user-defined large Html, ought to contain full description
   validDuration       Word Maybe                -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
-  auditDuration       Word Maybe                -- number of month to keep audit log; or indefinitely
+  auditDuration       Word Maybe                -- number of months to keep audit log and LmsUserIdents; or indefinitely  (dangerous, since LmsIdents may run out)
   refreshWithin       CalendarDiffDays Maybe    -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
   elearningStart      Bool                      -- automatically schedule e-refresher
   -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!
@@ -18,9 +18,9 @@ Qualification
 -- TODOs:
 --  - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
 --    Falls ja, so sollte bei automatischem refresher vorher der Kunde durch FRADrive befragt werden?!
---    A: Der Inhaber per Email informieren! 
+--    A: Der Inhaber per Email informieren!
 --    A: Es kann gleich eine LMS Pin generiert und verschickt werden!
---  - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay? 
+--  - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay?
 
 -- Besonderheiten:
 --  - LmsIdent muss für alle Qualificationen einzigartig sein!
@@ -33,7 +33,7 @@ Qualification
 
 QualificationPrecondition
   qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
-  required          [QualificationId]           -- OR : alternatives, any one will suffice 
+  required          [QualificationId]           -- OR : alternatives, any one will suffice
   continuous        Bool                        -- expiring precondition removes qualification
   deriving Generic
 
@@ -53,17 +53,17 @@ QualificationUser
   firstHeld         Day                           -- first time the qualification was earned, should never change
   blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked
   -- temporärer Entzug vorsehen
-  -- Begründungsfeld vorsehen 
+  -- Begründungsfeld vorsehen
   UniqueQualificationUser qualification user
   deriving Generic
 
   -- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
-  -- 
+  --
-  -- 1. Daily Job: Add to LmsUser daily all qualification holders with 
+  -- 1. Daily Job: Add to LmsUser daily all qualification holders with
-  --          QualificationUserValidUntil >= now 
+  --          QualificationUserValidUntil >= now
   --       /\ QualificationUserValudUntil <= now + QualificationRefreshWithin    (time to schedule refresher)
-  --       /\ not already enlisted  
+  --       /\ not already enlisted
-  -- 
+  --
   -- 2. REST GET User.csv:
   --     - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing)
   --     - delete-flag: isJust LmsUserStatus
@@ -77,60 +77,61 @@ QualificationUser
   --     - For all LmsUser:
   --         + if contained:
   --              set LmsUserReceived to Just now()
-  --              if LmsUserlistFailed: set LmsUserStatus to Just Day  
+  --              if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
   --         + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
   --     - move row to LmsAudit
   --
   -- 6. When received: Daily Job LmsResult:
-  --     - set LmsUserReceived to Just now()
+  --     - set LmsUserReceived to Just now()             -- always
-  --     - set LmsUserStatus  to Just Day    -- always
+  --     - set LmsUserStatus   to Just LmsSuccess now    -- conditional
+  --     -   and renew QualificationValidTo
   --     - move row to LmsAudit
   --
   -- 7. Daily Job: dequeue LMS Users
-  --     - renew qualification, if passed
   --     - remove from LmsUser after audit Period has passed
 
 LmsUser
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  user              UserId OnDeleteCascade OnUpdateCascade
+  user              UserId          OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent                    -- must be unique accross all LMS courses!
+  ident             LmsIdent                      -- must be unique accross all LMS courses!
   pin               Text
-  resetPin          Bool          default=false -- should pin be reset?
+  resetPin          Bool            default=false -- should pin be reset?
-  datePin           UTCTime       default=now() -- time pin was created
+  datePin           UTCTime         default=now() -- time pin was created
-  status            LmsStatus Maybe             -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS 
+  status            LmsStatus Maybe               -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
-  started           UTCTime       default=now()
+  started           UTCTime         default=now()
-  received          UTCTime Maybe               -- last acknowledgement by LMS 
+  received          UTCTime Maybe                 -- last acknowledgement by LMS
-  notified          UTCTime Maybe               -- last notified by FRADrive
+  notified          UTCTime Maybe                 -- last notified by FRADrive
-  ended             UTCTime Maybe               -- ident was deleted from LMS 
+  ended             UTCTime Maybe                 -- ident was deleted from LMS
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
-  UniqueLmsIdent ident                           -- idents must be unique accross all qualifications, since idents are global within LMS!
+  UniqueLmsIdent ident                            -- idents must be unique accross all qualifications, since idents are global within LMS!
-  UniqueLmsQualificationUser qualification user  -- each user may be enrolled at most once per course
+  UniqueLmsQualificationUser qualification user   -- each user may be enrolled at most once per course
   deriving Generic
 
--- LmsUserlist stores LMS upload for later processing only 
+-- LmsUserlist stores LMS upload for later processing only
 LmsUserlist
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade   
+  qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent
+  ident             LmsIdent        
   failed            Bool
-  timestamp         UTCTime default=now()
+  timestamp         UTCTime         default=now()
   UniqueLmsUserlist qualification ident
   deriving Generic
 
--- LmsResult stores LMS upload for later processing only 
+-- LmsResult stores LMS upload for later processing only
 LmsResult
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent
+  ident             LmsIdent        
   success           Day
-  timestamp         UTCTime default=now()
+  timestamp         UTCTime         default=now()
   UniqueLmsResult qualification ident -- required by DBTable
   deriving Generic
 
 -- Logs all processed rows from LmsUserlist and LmsResult
-LmsAudit 
+LmsAudit
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent
-  notificationType  LmsStatus               -- LmsBlocked Day | LmsSuccess Day   
+  notificationType  LmsStatus               -- LmsBlocked Day | LmsSuccess Day
+  note              Text Maybe
   received          UTCTime                 -- timestamp from LmsUserlist/LmsResult
-  processed         UTCTime default=now()
+  processed         UTCTime         default=now()
   deriving Generic

src/Handler/LMS/Result.hs

@@ -274,8 +274,8 @@ postLmsResultDirectR sid qsh = do
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do
             let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
-            $logWarnS "LMS" msg -- TODO: change to Info Level in the future
+            $logInfoS "LMS" msg
-            queueDBJob $ JobLmsResults qid
+            when (nr > 0) $ queueDBJob $ JobLmsResults qid
             return (ok200, msg)
     []     -> do
       let msg = "Result upload file missing."

src/Handler/LMS/Userlist.hs

@@ -270,8 +270,8 @@ postLmsUserlistDirectR sid qsh = do
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do
             let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
-            $logWarnS "LMS" msg -- TODO: change to Info Level in the future
+            $logInfoS "LMS" msg 
-            queueDBJob $ JobLmsUserlist qid
+            when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
             return (ok200, msg)
     []     -> do
       let msg = "Userlist upload file missing."

src/Handler/Utils/DateTime.hs

@@ -12,10 +12,10 @@ module Handler.Utils.DateTime
   , getTimeLocale, getDateTimeFormat
   , getDateTimeFormatter
   , validDateTimeFormats, dateTimeFormatOptions
-  , addLocalDays, addDiffDays
+  , addLocalDays
-  , addMonths, addMonthsDay
+  , addDiffDaysClip, addDiffDaysRollOver
   , addOneWeek, addWeeks
-  , fromMonths
+  , fromDays, fromMonths
   , weeksToAdd
   , setYear, getYear
   , firstDayOfWeekOnAfter
@@ -265,18 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
 -- CalendarDiffDays --
 ----------------------
 
-fromMonths :: Word -> CalendarDiffDays 
+fromMonths :: Integral a => a -> CalendarDiffDays 
-fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth
+fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
--- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
 
-addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime
+fromDays :: Integral a => a -> CalendarDiffDays 
-addDiffDays = over _utctDay . addGregorianDurationClip
+fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
 
-addMonths :: Word -> UTCTime -> UTCTime
+addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
-addMonths = addDiffDays . fromMonths
+addDiffDaysClip = over _utctDay . addGregorianDurationClip
 
-addMonthsDay :: Word -> Day -> Day 
+addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
-addMonthsDay = addGregorianMonthsClip . toInteger
+addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver
 
 weeksToAdd :: UTCTime -> UTCTime -> Integer
 -- ^ Number of weeks needed to add so that first

src/Jobs/Handler/LMS.hs

@@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E
 import Handler.Utils.DateTime 
 import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
 
--- import qualified Data.CaseInsensitive as CI
+import qualified Data.CaseInsensitive as CI
 
 
 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
@@ -47,9 +47,10 @@ dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsEnqueue qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
-    act = do
+    act = do    
-      $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "."
       quali <- getJust qid -- may throw an error, aborting the job
+      let qshort = CI.original $ qualificationShorthand quali
+      $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
       now <- liftIO getCurrentTime
       case qualificationRefreshWithin quali of
         Nothing -> return () -- no automatic scheduling for this qid
@@ -101,95 +102,45 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of
-        Nothing  -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
+        Nothing  -> do
+          uuid :: CryptoUUIDUser <- encrypt uid
+          $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
         (Just _) -> return () -- lmsUser started, but not yet notified
 
 
--- process all received input and renew or block qualifications
+-- purge LmsIdent adter QualificationAuditDuration expired
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsDequeue qid = JobHandlerAtomic act
+dispatchJobLmsDequeue qid = JobHandlerAtomic act  
-  -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
   where
-    act = do
+    act = do      
-      $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
       quali <- getJust qid -- may throw an error, aborting the job
+      let qshort = CI.original $ qualificationShorthand quali
+      $logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort
       now <- liftIO getCurrentTime
       -- purge LmsUsers 
       case qualificationAuditDuration quali of
         Nothing -> return () -- no automatic removal
-        (Just auditDuration) -> 
+        (Just auditDuration) -> do
-          let auditCutoff = addDiffDaysRollover (fromMonths $ negate auditDuration) now
+          let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
-          delusers <- fmap E.unValue $ E.select $ do
+          delusersVals <- E.select $ do
             luser <- E.from $ E.table @LmsUser
             E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
                   E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff)
                   E.&&. E.isJust (luser E.^. LmsUserEnded)
                   E.&&. E.notExists (do
-                          audit <- E.from $ E.table @LmsAudit
+                          laudit <- E.from $ E.table @LmsAudit
-                          E.where_ $  audit E.^. LmsAuditQualification E.==. E.val qid
+                          E.where_ $  laudit E.^. LmsAuditQualification E.==. E.val qid
-                              E.&&.   audit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
+                              E.&&.   laudit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
-                              E.&&.   audit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
+                              E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
                         )
             pure (luser E.^. LmsUserIdent)
+          let numdel = length delusers
+              delusers = E.unValue <$> delusersVals
+          when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
           deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
           deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
-          deleteWhere [LmsResult                ==. qid, LmsResultIdent   <-. delusers]
+          deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
-          deleteWhere [LmsAudit                 ==. qid, LmsAuditIdent    <-. delusers]
+          deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
-
-
-
-      deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded <. Just lmsCutoff]
-      -- purge LmsAudit
-      
-          in E.delete $ do
-            audit <- E.from $ E.table @LmsAudit
-            E.where_  $ audit E.^. LmsAuditQualification E.==. E.val qid
-                E.&&. E.notExists (do
-                        luser <- E.from $ E.table @LmsUser
-                        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid 
-                            E.&&.  luser E.^. LmsUserIdent E.==. audit E.^. LmsAuditIdent
-                      )
-            E.groupBy $ audit E.^. LmsAuditIdent
-            E.having  $ E.val auditCutoff E.<. E.max_ (audit E.^. LmsAuditProcessed)
-
-
-
-          in  deleteWhere [LmsAuditQualification ==. qid, LmsAuditProcessed >. Just deleteDate]
-
-
-      
-      let auditCutoff = 
-        
-        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)
-      
-      
-      case qualificationRefreshWithin quali of
-        Nothing -> return () -- no automatic deletion
-        (Just auditDuration) -> 
-            return ()  -- TODO
-
-            deleteWhere [LmsUserEnded >. ]
-          {- do
-          now_day <- utctDay <$> liftIO getCurrentTime
-          let _renewalDate = addGregorianDurationClip renewalPeriod now_day
-
-          -- CONTINUE HERE: TODO          
-          --   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 now_day              -- 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)
-          -}
 
 
 -- processes received results and lengthen qualifications, if applicable
@@ -226,7 +177,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
             saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
                           && qualificationUserLastRefresh <= lmsUserStartedDay
             newStatus   = LmsSuccess lmsResultSuccess
-            newValidTo  = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
+            newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
         note <- if saneDate && isLmsSuccess newStatus
           then do
             update quid [ QualificationUserValidUntil  =. newValidTo

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -59,7 +59,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
 
-  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
+  $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
 
   now <- liftIO getCurrentTime
   letterDate <- formatTimeUser SelFormatDate now                         $ Just entRecipient

src/Model/Types/Lms.hs

@@ -31,17 +31,23 @@ deriveJSON defaultOptions
 -- ...also see similar type QualificationBlocked
 data LmsStatus = LmsBlocked { lmsStatusDay :: Day } 
                | LmsSuccess { lmsStatusDay :: Day }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
+  deriving (Eq, Read, Show, Generic, Typeable, NFData)
+
+instance Ord LmsStatus where 
+  compare a b
+    | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
+    , daycmp /= EQ = daycmp    
+  compare LmsSuccess{} LmsBlocked{} = GT
+  compare LmsBlocked{} LmsSuccess{} = LT 
+  compare _            _            = EQ 
 
 isLmsSuccess :: LmsStatus -> Bool 
 isLmsSuccess LmsSuccess{} = True 
 isLmsSuccess _other       = False 
 
--- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec
+-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
--- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird!
 instance Semigroup LmsStatus where 
-  a <> b | a >= b    = a  
+  a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess         
-         | otherwise = b
 
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already

test/Model/TypesSpec.hs

@@ -620,10 +620,8 @@ spec = do
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
   describe "Semigroup LmsStatus" $ do 
-    it "LmsSuccess supersedes LmsBlocked" . property $
+    it "lmsStatusDay merges to earliest" . property $
-      \p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2)
+      \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) 
-    it "lmsStatusDay merges to latest" . property $
-      \p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2) 
 
 
 termExample :: (TermIdentifier, Text) -> Expectation