chore(lms): lmsstatus to semigroup for easy switch, lms notficiation stub

models/lms.model

@@ -3,9 +3,9 @@ Qualification
   shorthand           (CI Text)
   name                (CI Text)
   description         StoredMarkup Maybe        -- user-defined large Html, ought to contain full description
-  validDuration       Word Maybe                -- qualification is valid for this number of months or indefinitely
+  validDuration       Word Maybe    -- qualification is valid indefinitely or for a specified time period
   auditDuration       Word Maybe                -- number of month to keep audit log
-  refreshWithin       CalendarDiffDays Maybe    -- automatically schedule e-refresher within this number of month/days before expiry
+  refreshWithin       CalendarDiffDays Maybe    -- notify users about renewal within this number of month/days before expiry
   elearningStart      Bool                      -- automatically schedule e-refresher
   -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!
   -- refreshInvitation   StoredMarkup           -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
@@ -71,7 +71,7 @@ QualificationUser
   --
   -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult
   --
-  -- 5. Daily Job LmsUserlist:               -- Note: containment needs at-once processing
+  -- 5. When received: Job LmsUserlist:               -- Note: containment needs at-once processing
   --     - For all LmsUser:
   --         + if contained:
   --              set LmsUserReceived to Just now()
@@ -79,11 +79,14 @@ QualificationUser
   --         + not contianed, by LmsUserReceived is set: set LmsUserEnded to Just now()
   --     - move row to LmsAudit
   --
-  -- 6. Daily Job LmsResult:
+  -- 6. When received: Daily Job LmsResult:
   --     - set LmsUserReceived to Just now()
   --     - set LmsUserStatus  to Just Day    -- always
   --     - move row to LmsAudit
-
+  --
+  -- 7. Daily Job: dequeue LMS Users
+  --     - 
+  --     - remove from LmsUser after audit Period has passed
 
 LmsUser
   qualification     QualificationId OnDeleteCascade OnUpdateCascade

src/Jobs/Handler/LMS.hs

@@ -28,8 +28,8 @@ dispatchJobLmsQualifications = JobHandlerAtomic act
     act = do 
       qids <- E.select $ do 
                 q <- E.from $ E.table @Qualification
-                E.where_ $  q E.^. QualificationElearningStart
+                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
-                      E.&&. 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         
         $logInfoS "lms" $ "Start e-learning for qualification " <> tshow qid <> "."
@@ -58,8 +58,19 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                           E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid 
                                 E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
                         )
-            pure (quser E.^. QualificationUserUser)
+            pure quser
-          forM_ renewalUsers (\uid -> queueDBJob JobLmsEnqueueUser { jQualification = qid, jUser = E.unValue uid } )
+          let usr_job :: Entity QualificationUser -> Job 
+              usr_job quser = 
+                let uid = quser ^. _entityVal . _qualificationUserUser      
+                    _uex = quser ^. _entityVal . _qualificationUserValidUntil
+                in if qualificationElearningStart quali
+                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
+                    else error "TODO: send Notfification"
+                          {-
+                          JobSendNotification { jRecipientEmail = uid, jNotification = 
+                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
+                            } -}
+          forM_ renewalUsers (queueDBJob . usr_job)
 
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
@@ -84,8 +95,10 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of 
         Nothing  -> $logErrorS "LMS" "Generating and inserting fresh LmsIdent failed!"
-        (Just _) -> error "continue here by notifying user by email or mail"
+        (Just _) -> error "TODO: send notification"
-
+                    {- queueDBJob JobSendNotification { jRecipientEmail = uid, jNotification = 
+                        NotificationQualificationRenewal { nQualification = qid }
+                    } -}
 
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsDequeue _qid = 
@@ -100,30 +113,6 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
       now <- liftIO getCurrentTime
-      {- Unfortunately, we cannot use insertSelect due to Haskell-Type changes and deletion of keys
-      E.insertSelectWithConflict 
-        (UniqueLmsUser $ error "insertSelectWithConflict inspected constraint") -- never executed, just a type hint
-        (do 
-          (luser E.:& lresult) <- 
-            E.from $ E.table @LmsUser `E.innerJoin` E.table @LmsResult `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent 
-                                                                                E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification
-                                                                              )          
-          E.where_ $ lresult E.^. LmsResultQualification E.==. E.val qid
-          return $ LmsUser E.<# E.val qid
-                          E.<&> (luser   E.^. LmsUserUser)
-                          E.<&> (luser   E.^. LmsUserIdent)
-                          E.<&> (luser   E.^. LmsUserPin)
-                          E.<&> (luser   E.^. LmsUserResetPin)
-                          E.<&> (E.val $ (LmsSuccess . E.unValue) <$> (lresult E.^. LmsResultSuccess)) -- how to convert Day to LmsStatus here?
-                          E.<&> (luser   E.^. LmsUserStarted)
-                          E.<&> E.just (lresult E.^. LmsResultTimestamp)
-                          E.<&> (luser   E.^. LmsUserEnded)
-        )
-        (\current _excluded ->
-          [ LmsUserStatus E.=. current E.^. LmsUserStatus, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
-        )
-      -- Unclear how to delete here
-      -}
       -- result :: [(Entity LmsUser, Entity LmsResult)]
       results <- E.select $ do 
         (luser E.:& lresult) <- E.from $ 
@@ -136,12 +125,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
       forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do 
         -- three separate DB operations per result is not so nice. All within one transaction though.
         let lreceived = lmsResultTimestamp lresult 
-            lstatus   = lmsResultSuccess   lresult & LmsSuccess
+            newStatus = lmsResultSuccess   lresult & LmsSuccess 
+            oldStatus = lmsUserStatus luser
         -- always log success, since this is only transmitted once
-        update luid [ LmsUserStatus   =. Just lstatus
+        update luid [ LmsUserStatus   =. (oldStatus <> Just newStatus)
                     , LmsUserReceived =. Just lreceived 
                     ]
-        insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now
+        insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
         delete lrid                   
       $logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|]
 
@@ -168,14 +158,13 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
           | otherwise -> return () -- likely not yet started
 
         (Entity luid luser, Just (Entity lulid lulist)) -> do           
-          let usrNoStat = isNothing $ lmsUserStatus luser
+          let lReceived = lmsUserlistTimestamp lulist
-              lBlocked  = lmsUserlistFailed    lulist              
+              isBlocked = lmsUserlistFailed lulist
-              updStatus = lBlocked && usrNoStat -- only update empty status to blocked
+              newStatus = LmsBlocked $ utctDay lReceived
-              lReceived = lmsUserlistTimestamp lulist
+              oldStatus = lmsUserStatus luser
-              lStatus   = LmsBlocked $ utctDay lReceived
+          update luid   [ LmsUserStatus   =. (oldStatus <> toMaybe isBlocked newStatus)
-          update luid $ [ LmsUserStatus   =. Just lStatus   | updStatus ]
+                        , LmsUserReceived =. Just lReceived ]
-                     <> [ LmsUserReceived =. Just lReceived ]
+          when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked
-          when lBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) lStatus lReceived now -- always log blocked
           delete lulid
 
       $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

src/Jobs/Handler/SendNotification.hs

@@ -20,6 +20,7 @@ import Jobs.Handler.SendNotification.Allocation
 import Jobs.Handler.SendNotification.ExamOffice
 import Jobs.Handler.SendNotification.CourseRegistered
 import Jobs.Handler.SendNotification.SubmissionEdited
+-- import Jobs.Handler.SendNotification.Qualification -- TODO
 
 
 dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX

src/Jobs/Types.hs

@@ -141,6 +141,8 @@ data Notification
   | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
   | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
   | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
+  -- | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day }
+  -- | NotificationQualificationRenewal { nQualification :: QualificationId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job

src/Model/Types/Lms.hs

@@ -32,6 +32,14 @@ data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
                | LmsSuccess { lmsStatusDay :: Day }
   deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
 
+-- Variante 1: Der spätere Zeitstempel gewinnt, bei gleichem Zeitstempel gewinnt LmsSuccess? TODO: Macht das Sinn?!
+-- Variante 2: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt?
+instance Semigroup LmsStatus where 
+  a <> b | lmsStatusDay a > lmsStatusDay b = a -- nur Variante 1
+         | lmsStatusDay a < lmsStatusDay b = b -- nur Variante 1
+         | a >= b    = a  -- Variante 1 & 2, berücksichtigt Ord
+         | otherwise = b
+
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already
   , fieldLabelModifier     = camelToPathPiece' 2      -- just day suffices for the day field

src/Utils/Lens.hs

@@ -114,6 +114,7 @@ makeClassyFor_ ''StudyTerms
 makeClassyFor_ ''StudySubTerms
 
 makeClassyFor_ ''Qualification
+makeClassyFor_ ''QualificationUser
 makeClassyFor_ ''LmsUser
 makeClassyFor_ ''LmsUserlist
 makeClassyFor_ ''LmsResult