refactor(qualifications): notification mechanic tied to button only for all invalid qualifications

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

@@ -19,6 +19,7 @@ TableQualificationSapExport: SAP
 TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
 LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
+TableQualificationLastNotified: Letzte Benachrichtigung
 TableQualificationFirstHeld: Erstmalig
 TableQualificationBlockedDue: Entzogen
 TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?

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

@@ -19,6 +19,7 @@ TableQualificationSapExport: Sent to SAP
 TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
 LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
+TableQualificationLastNotified: Last notified
 TableQualificationFirstHeld: First held
 TableQualificationBlockedDue: Revoked
 TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?

models/lms.model

@@ -62,6 +62,7 @@ QualificationUser
   firstHeld         Day                           -- first time the qualification was earned, should never change
   blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked
   scheduleRenewal   Bool  default=true            -- if false, no automatic renewal is scheduled and the qualification expires
+  lastNotified      UTCTime default=now()         -- last notficiation about being invalid
   -- temporärer Entzug vorsehen -- SAP Schnittstelle muss dann angepasst werden
   -- Begründungsfeld vorsehen
   UniqueQualificationUser qualification user

src/Handler/LMS/Fake.hs

@@ -131,6 +131,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
                   qualificationUserLastRefresh      = qualificationUserFirstHeld
                   qualificationUserBlockedDue       = Nothing
                   qualificationUserScheduleRenewal  = True
+                  qualificationUserLastNotified     = now
               _ <- upsert QualificationUser{..} 
                           [ QualificationUserValidUntil  =. qualificationUserValidUntil
                           , QualificationUserLastRefresh =. qualificationUserLastRefresh

src/Handler/Qualification.hs

@@ -340,6 +340,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       , single $ sortUserMatriclenr queryUser
       , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
+      , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
       , single ("blocked-due"   , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       -- , single ("lms-started"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
       -- , single ("lms-status"    , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
@@ -521,6 +522,7 @@ postQualificationR sid qsh = do
           -- , sortable (Just "lms-status")    (i18nCell MsgTableLmsStatus)               $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)  -> foldMap lmsStatusCell $ join status          
           , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
                                                                                        $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu
+          , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
           ]
         psValidator = def & defaultSorting [SortDescBy "last-refresh"]
     tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator

src/Handler/Utils/Qualification.hs

@@ -14,7 +14,7 @@ import Database.Persist.Sql (updateWhereCount)
 import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils as E
 
-
+import Handler.Utils.DateTime (toMidnight)
 
 ------------------
 -- SQL Snippets --
@@ -57,6 +57,7 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       { qualificationUserFirstHeld        = qualificationUserLastRefresh
       , qualificationUserBlockedDue       = Nothing
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
+      , qualificationUserLastNotified     = toMidnight qualificationUserLastRefresh
       , ..
       }
     (

src/Handler/Utils/Users.hs

@@ -827,6 +827,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
           E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
           E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
           E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal)
+          E.<&> (qualificationUser E.^. QualificationUserLastNotified)
     )
     (\current excluded ->
       [ QualificationUserValidUntil       E.=. combineWith current excluded E.greatest QualificationUserValidUntil
@@ -834,6 +835,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       , QualificationUserFirstHeld        E.=. combineWith current excluded E.least    QualificationUserFirstHeld
       , QualificationUserBlockedDue       E.=. combineWith current excluded E.greatest QualificationUserBlockedDue  -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
       , QualificationUserScheduleRenewal  E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal
+      , QualificationUserLastNotified     E.=. combineWith current excluded E.greatest QualificationUserLastNotified
       ]
     )
   deleteWhere [ QualificationUserUser ==. oldUserId ]

src/Jobs/Handler/LMS.hs

@@ -158,13 +158,23 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
         E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)]
         E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
       $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
-      -- TODO: notify expired used 
+
-          -- 
+      notifyInvalidDrivers <- E.select $ do 
-          -- forM_ expiredLearners $ \uid ->
+          quser <- E.from $ E.table @QualificationUser 
-          --   queueDBJob JobSendNotification
+          E.where_ $ E.not_ (validQualification nowaday quser)              
-          --     { jRecipient    = uid
+            E.&&. ((  E.isNothing (quser E.^. QualificationUserBlockedDue)
-          --     , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
+                    E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil)
-          --     }
+            ) E.||. (
+                      E.isJust    (quser E.^. QualificationUserBlockedDue)
+                    E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. ((quser E.^. QualificationUserBlockedDue) E.->. "day" :: E.SqlExpr (E.Value Day)))
+            ))
+          pure (quser E.^. QualificationUserUser)      
+      
+      forM_ notifyInvalidDrivers $ \(E.Value uid) ->
+        queueDBJob JobSendNotification
+          { jRecipient    = uid
+          , jNotification = NotificationQualificationExpired { nQualification = qid }
+          }
 
       -- purge outdated LmsUsers
       case qualificationAuditDuration quali of
@@ -306,10 +316,11 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
               }
             update luid [LmsUserStatus =. newStatus]
             void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay
-            queueDBJob JobSendNotification
+            -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later!
-              { jRecipient    = lmsUserUser luser
+            -- queueDBJob JobSendNotification
-              , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay }
+            --   { jRecipient    = lmsUserUser luser
-              }
+            --   , jNotification = NotificationQualificationExpired { nQualification = qid }
+            --   }
 
           delete lulid
       $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -42,25 +42,44 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user
   addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
 
 
-dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler ()
+dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
-dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do
+dispatchNotificationQualificationExpired nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
+  encRecipient :: CryptoUUIDUser <- encrypt jRecipient
-    <$> getJust jRecipient
+  dbRes <- runDB $ (,,)
-    <*> getJust nQualification
+    <$> get jRecipient
+    <*> get nQualification
+    <*> getBy (UniqueQualificationUser nQualification jRecipient)
 
-  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
+  case dbRes of 
-  let entRecipient = Entity jRecipient recipient
+    ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do
-      qname = CI.original qualificationName
+      urender <- getUrlRender
-  expiryDate <- fmap Just $ formatTimeUser SelFormatDate dExpired $ Just entRecipient
+      let expDay  = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue
-
+          qname   = CI.original qualificationName
-  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname
+          qshort  = CI.original qualificationShorthand
-
+          letter  = LetterExpireQualificationF 
-  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+            { leqfHolderUUID = encRecipient
-  setSubjectI $ MsgMailSubjectQualificationExpired qname
+            , leqfHolderID   = jRecipient
-
+            , leqfHolderDN   = userDisplayName
-  editNotifications <- mkEditNotifications jRecipient
+            , leqfHolderSN   = userSurname
-
+            , leqfExpiry     = Just expDay
-  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet")
+            , leqfId         = nQualification
+            , leqfName       = qname
+            , leqfShort      = qshort
+            , leqfSchool     = qualificationSchool
+            , leqfUrl        = pure . urender $ ForProfileDataR encRecipient
+            }
+      if expDay > utctDay qualificationUserLastNotified 
+        then do
+          notifyOk <- sendEmailOrLetter jRecipient letter
+          if notifyOk
+            then do 
+              now <- liftIO getCurrentTime
+              runDB $ update quId [QualificationUserLastNotified =. now]
+              $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
+            else 
+              $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
+        else  $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
+    _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
 
 
 -- NOTE: Renewal expects that LmsUser already exists for recipient
@@ -75,7 +94,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
   case query of 
     (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do
       let qname = CI.original qualificationName
-      let letter = LetterRenewQualificationF
+          letter = LetterRenewQualificationF
             { lmsLogin     = lmsUserIdent
             , lmsPin       = lmsUserPin
             , qualHolderID = jRecipient

src/Jobs/Types.hs

@@ -142,7 +142,7 @@ data Notification
   | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
   | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
   | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day }
-  | NotificationQualificationExpired { nQualification :: QualificationId, nExpiry :: Day }
+  | NotificationQualificationExpired { nQualification :: QualificationId }
   | NotificationQualificationRenewal { nQualification :: QualificationId }
   deriving (Eq, Ord, Show, Read, Generic)
 

src/Utils/Print.hs

@@ -305,8 +305,9 @@ sendEmailOrLetter recipient letter = do
     --     $logErrorS "LETTER" msg
     --     return False
     --      
-    --   (False, _) -> do -- send Email
+    --   (False, _) | attachPDFLetter letter -> do -- send Email, with pdf attached 
-    --     if attachPDFLetter 
+    --   (False, _) -> -- send Email, render letter directly to html
+    --   (True , postal) -> -- send printed letter
     --
     let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
     -- mailBody <- getMailBody letter formatter

test/Database/Fill.hs

@@ -691,23 +691,23 @@ fillDb = do
   qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True  (Just AvsLicenceVorfeld)  $ Just "F4466"
   qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3)  False (Just AvsLicenceRollfeld) $ Just "R2801"
   qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True Nothing Nothing
-  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $   -1) (n_day $   -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $   -1) (n_day $   -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates!
-  void . insert' $ QualificationUser jost       qid_r (n_day   99) (n_day $  -11) (n_day $  -222) Nothing True -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_r (n_day   99) (n_day $  -11) (n_day $  -222) Nothing True (n_day' $ -9) -- TODO: better dates!
-  void . insert' $ QualificationUser jost       qid_l (n_day  999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_l (n_day  999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates!
-  void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True
+  void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True (n_day' $ -9)
-  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) Nothing False
+  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) Nothing False (n_day' $ -1)
-  void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2) Nothing True
+  void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2) Nothing True (n_day' $ -9)
-  void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200) Nothing True
+  void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200) Nothing True (n_day' $ -2)
-  void . insert' $ QualificationUser tinaTester qid_f (n_day    3) (n_day $ -60) (n_day $ -250)  (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False
+  void . insert' $ QualificationUser tinaTester qid_f (n_day    3) (n_day $ -60) (n_day $ -250)  (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False (n_day' $ -9)
-  void . insert' $ QualificationUser tinaTester qid_r (n_day    3) (n_day $ -60) (n_day $ -250)  Nothing False
+  void . insert' $ QualificationUser tinaTester qid_r (n_day    3) (n_day $ -60) (n_day $ -250)  Nothing False (n_day' $ -3)
-  void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9) Nothing True
+  void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9) Nothing True (n_day' $ -4)
-  void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2) Nothing False
+  void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2) Nothing False (n_day' $ -6)
-  -- void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2) Nothing True
+  -- void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2) Nothing True (n_day' $ -9)
-  void . insert' $ QualificationUser svaupel    qid_l (n_day    1) (n_day $ -1) (n_day $  -2) Nothing True
+  void . insert' $ QualificationUser svaupel    qid_l (n_day    1) (n_day $ -1) (n_day $  -2) Nothing True (n_day' $ -7)
-  void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7) Nothing True
+  void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7) Nothing True (n_day' $ -8)
   qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal)
                <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser]
-  insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True | Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers]
+  insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers]
   void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
   void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
   void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now