refactor(lms): send user notifications only after lms acknowleged e-learning

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -23,12 +23,14 @@ TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
 TableLmsStarted: Begonnen
 TableLmsReceived: Letzte Rückmeldung
+TableLmsNotified: Versand Benachrichtigung
 TableLmsEnded: Beended
 TableLmsStatus: Status E-Lernen
 TableLmsSuccess: Bestanden
 TableLmsFailed: Gesperrt
 FilterLmsValid: Aktuell gültig
 FilterLmsRenewal: Erneuerung anstehend
+FilterLmsNotified: Benachrichtigt
 CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
 CsvColumnLmsPin: PIN des E-Lernen Zugangs
 CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?

messages/uniworx/categories/qualification/en-eu.msg

@@ -23,12 +23,14 @@ TableLmsDelete: Delete?
 TableLmsStaff: Staff?
 TableLmsStarted: Started
 TableLmsReceived: Last update
+TableLmsNotified: Notification sent
 TableLmsEnded: Ended
 TableLmsStatus: Status e-learning
 TableLmsSuccess: Completed
 TableLmsFailed: Blocked
 FilterLmsValid: Currently valid
 FilterLmsRenewal: Renewal due
+FilterLmsNotified: Notified
 CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
 CsvColumnLmsPin: PIN for e-learning access
 CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?

models/lms.model

@@ -100,6 +100,7 @@ LmsUser
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
   started           UTCTime       default=now()
   received          UTCTime Maybe               -- last acknowledgement by LMS 
+  notified          UTCTime Maybe               -- last notified by FRADrive
   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!

src/Handler/LMS.hs

@@ -343,6 +343,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
       , single ("lms-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
       , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
+      , single ("lms-notified", SortColumn $ queryLmsUser  >>> (E.?. LmsUserNotified))
       , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
     dbtFilter = mconcat
@@ -356,12 +357,19 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
                                           E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
              | otherwise -> E.true
         )
+      , single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion ->
+          case getLast criterion of
+            Just True  -> E.isJust    $ luser E.?. LmsUserNotified
+            Just False -> E.isNothing $ luser E.?. LmsUserNotified
+            Nothing    -> E.true
+        )
       ]
     dbtFilterUI mPrev = mconcat
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
-      , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+      , prismAForm (singletonFilter "lms-ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-      , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
       , if isNothing mbRenewal then mempty
         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
       ]
@@ -446,6 +454,7 @@ postLmsR sid qsh = do
           , sortable (Just "lms-started")   (i18nLms MsgTableLmsStarted)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
+          , sortable (Just "lms-notified")  (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
           , sortable (Just "lms-ended")     (i18nLms MsgTableLmsEnded)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell $ join d
           ]
           where

src/Jobs/Handler/LMS.hs

@@ -23,17 +23,20 @@ import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
 
 
 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
-dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act
+dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
-  where
+
-    act :: YesodJobDB UniWorX ()
+dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
-    act = do 
+dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue
-      qids <- E.select $ do 
+
-                q <- E.from $ E.table @Qualification
+-- execute given job for all qualifications that allow refreshs
-                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
-                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
+fetchRefreshQualifications qidJob = do
-                pure $ q E.^. QualificationId
+  qids <- E.select $ do
-      forM_ qids $ \(E.unValue -> qid) ->
+            q <- E.from $ E.table @Qualification
-        queueDBJob $ JobLmsEnqueue qid 
+            E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+            pure $ q E.^. QualificationId
+  forM_ qids $ \(E.unValue -> qid) ->
+    queueDBJob $ qidJob qid
 
 
 -- | enlist expiring qualification holders to e-learning
@@ -43,7 +46,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = do
-      $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."        
+      $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "."
       quali <- getJust qid -- may throw an error, aborting the job
       now <- liftIO getCurrentTime
       case qualificationRefreshWithin quali of
@@ -94,6 +97,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserStatus        = Nothing
             , lmsUserStarted       = now
             , lmsUserReceived      = Nothing
+            , lmsUserNotified      = Nothing
             , lmsUserEnded         = Nothing
             }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
@@ -101,41 +105,27 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of
         Nothing  -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
-        (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = 
+        (Just _) -> return () -- lmsUser started, but not yet notified
-                        NotificationQualificationRenewal { nQualification = qid }
-                      }
 
 
-dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
+-- process all received input and renew qualifications
-dispatchJobLmsQualificationsDequeue = 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 = JobHandlerAtomic act
   -- wenn bestanden: qualification verlängern
   -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
   where
     act = do
-      $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "."        
+      $logInfoS "lms" $ "Processing 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 
+        Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above)
         (Just renewalPeriod) -> do
           now_day <- utctDay <$> liftIO getCurrentTime
           let renewalDate = addGregorianDurationClip renewalPeriod now_day
 
-          -- CONTINUE HERE:
+          -- CONTINUE HERE: TODO
           --   select users that need renewal due to success
-          --   delete users after audit period has expired            
+          --   delete users after audit period has expired!!!
 
           renewalUsers <- E.select $ do
             (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
@@ -150,7 +140,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
             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 qualification that have infinite validity?!
+                    pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?!
                     vnew   = addGregorianDurationClip pmonth vold
                     lmsstatus = luser ^. _entityVal . _lmsUserStatus
                 in case lmsstatus of
@@ -159,6 +149,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
           forM_ renewalUsers usr_job
 
 
+-- just processes received input, but does not affect any exisitng qualifications yet
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsResults qid = JobHandlerAtomic act
   where
@@ -192,11 +183,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
         delete lrid
       $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
 
+
+-- just processes received input, but does not affect any exisitng qualifications yet
 dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsUserlist  qid = JobHandlerAtomic act
   where
-    -- act :: YesodJobDB UniWorX ()
+    act :: YesodJobDB UniWorX ()
-    act = hoist lift $ do
+    act = do
       now <- liftIO getCurrentTime
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
@@ -209,12 +202,17 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
         return (luser, lulist)
       forM_ results $ \case
         (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser
+          | isJust    $ lmsUserReceived luser          -- mark all unreported users as ended
           , isNothing $ lmsUserEnded    luser ->
               update luid [LmsUserEnded =. Just now]
-          | otherwise -> return () -- likely not yet started
+          | otherwise -> return ()                     -- users likely not yet started
 
         (Entity luid luser, Just (Entity lulid lulist)) -> do
+          when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available
+            queueDBJob JobSendNotification
+              { jRecipient    = lmsUserUser luser
+              , jNotification = NotificationQualificationRenewal { nQualification = qid }
+              }
           let lReceived = lmsUserlistTimestamp lulist
               isBlocked = lmsUserlistFailed lulist
               newStatus = LmsBlocked $ utctDay lReceived

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
 -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
+  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
     <$> getJust jRecipient
     <*> getJust nQualification
     <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
@@ -120,5 +120,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
 
         editNotifications <- mkEditNotifications jRecipient
         addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
+  -- if we reach the end, mark the user as notified
+  -- TODO: defer this until the print job is marked as sent?
+  runDB $
+    update luid [ LmsUserNotified =. Just now]
 
     

test/Database/Fill.hs

@@ -522,11 +522,11 @@ fillDb = do
   void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
   void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now
   void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now
-  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing now Nothing Nothing
+  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing                           now Nothing    Nothing Nothing
-  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1)     now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")    "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing
+  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just $ LmsSuccess $ n_day (-2))  now Nothing    (Just $ n_day' (-1)) Nothing
-  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")    "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1))
+  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1))  now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
 
   void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing        (Just svaupel)  Nothing (Just qid_f)
   void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_f)