chore(qualifications): show qualifications on user profile page and send expired notifications

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

@@ -13,6 +13,7 @@ LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationFirstHeld: Erstmalig
 TableQualificationBlockedDue: Suspendiert
+TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und wer hat das veranlasst?
 LmsUser: Inhaber
 TableLmsEmail: E-Mail
 TableLmsIdent: Identifikation
@@ -49,8 +50,10 @@ LmsDirectUpload: Direkter Upload für automatisierte Systeme
 LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
 MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
 MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
+MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
 MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
 MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
+MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Lernen.
 LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
 LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden.
 LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden

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

@@ -13,6 +13,7 @@ LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held
 TableQualificationBlockedDue: Suspended
+TableQualificationBlockedTooltip: When was the qualification temporarily suspended and who requested this?
 LmsUser: Licensee
 TableLmsEmail: Email
 TableLmsIdent: Identifier
@@ -49,8 +50,10 @@ LmsDirectUpload: Direct upload for automated Systems
 LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
 MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
+MailSubjectQualificationExpired qname@Text: Qualification #{qname} is no longer valid
 MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
 MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
+MailBodyQualificationExpired: This qualificaton is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning.
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
 LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. 
 LmsActNotify: Resend e-learning notification by post or email

messages/uniworx/categories/settings/personal_settings/de-de-formal.msg

@@ -14,6 +14,7 @@ ProfileTutorialParticipations: Tutorien
 ProfileSubmissionGroups: Abgabegruppen
 ProfileSubmissions: Abgaben
 ProfileRemark: Hinweis
+ProfileQualifications: Eigene Qualifikationen
 PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt.
 PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
 PersonalInfoTutorialsWip: Die Anzeige von Tutorien, zu denen Sie angemeldet sind wird momentan an dieser Stelle leider noch nicht unterstützt.

messages/uniworx/categories/settings/personal_settings/en-eu.msg

@@ -14,6 +14,7 @@ ProfileTutorialParticipations: Tutorials
 ProfileSubmissionGroups: Submission groups
 ProfileSubmissions: Submissions
 ProfileRemark: Remarks
+ProfileQualifications: Owned Qualifications
 PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented.
 PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented.
 PersonalInfoTutorialsWip: The feature to display tutorials you have registered for has not yet been implemented.

models/lms.model

@@ -115,7 +115,7 @@ LmsUserlist
   failed            Bool
   timestamp         UTCTime         default=now()
   UniqueLmsUserlist qualification ident
-  deriving Generic
+  deriving Generic Show
 
 -- LmsResult stores LMS upload for later processing only
 LmsResult

src/Application.hs

@@ -252,7 +252,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
-      $logDebugS "Configuration" $ tshowCrop appSettings''
+      $logInfoS "Configuration" $ tshowCrop appSettings''
       $logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
 
       smtpPool <- for appSmtpConf $ \c -> do

src/Handler/LMS.hs

@@ -352,10 +352,10 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
     dbtSorting = mconcat
       [ single $ sortUserNameLink queryUser
       , single $ sortUserEmail    queryUser
+      , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
-      , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))      
-      , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
       , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
       , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
@@ -477,7 +477,8 @@ postLmsR sid qsh = do
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
-          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue) $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
+          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
+                                                                                     ) $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
           , sortable (Just "lms-ident")     (i18nLms MsgTableLmsIdent)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
           , sortable (Just "lms-status")    (i18nLms MsgTableLmsStatus)   $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)            -> foldMap lmsStatusCell $ join status
           , sortable (Just "lms-started")   (i18nLms MsgTableLmsStarted)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell        d

src/Handler/Profile.hs

@@ -647,6 +647,7 @@ makeProfileData (Entity uid User{..}) = do
   submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
   correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
+  qualificationsTable  <- mkQualificationsTable       uid -- Tabelle mit allen Qualifikationen
   let examTable, ownTutorialTable, tutorialTable :: Widget
       examTable        = i18n MsgPersonalInfoExamAchievementsWip
       ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@@ -978,6 +979,52 @@ mkCorrectionsTable =
               in  dbTableWidget' validator DBTable{..}
 
 
+
+-- | Table listing all qualifications that the given user is enrolled in
+mkQualificationsTable :: UserId -> DB Widget
+mkQualificationsTable =
+  let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a)
+               -> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a)
+      withType = id
+
+      validator = def -- TODO & defaultSorting [SortDescBy "valid-until"]
+
+  in \uid -> dbTableWidget' validator
+    DBTable
+      { dbtIdent     = "userQualifications" :: Text
+      , dbtSQLQuery  = \(quali `E.InnerJoin` quser) -> do
+          E.on $ quali E.^. QualificationId E.==. quser E.^. QualificationUserQualification
+          E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid               
+          return (quali, quser)
+      , dbtRowKey = \(_quali `E.InnerJoin` quser) -> quser E.^. QualificationUserId
+      , dbtProj      = dbtProjId 
+      , dbtColonnade = mconcat
+          [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
+          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationCell         <$> view (_dbrOutput . _1 . _entityVal)
+          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
+                                                                                     )  $ qualificationBlockedCell  <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue )
+          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)    $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
+          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh) $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
+          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)   $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld  )          
+          ]
+      , dbtSorting   = mconcat
+          [ sortSchool $ to (\(quali `E.InnerJoin` _) -> quali E.^. QualificationSchool)
+          , singletonMap "quali"        $ SortColumn $ withType $ \(quali `E.InnerJoin` _) -> quali E.^. QualificationName  
+          , singletonMap "blocked-due"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserBlockedDue
+          , singletonMap "valid-until"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserValidUntil
+          , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserLastRefresh
+          , singletonMap "first-held"   $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserFirstHeld          
+          ]
+      , dbtFilter    = mempty
+      , dbtFilterUI  = mempty
+      , dbtStyle     = def
+      , dbtParams    = def
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
+      , dbtExtraReps = []
+      }
+
+
 getAuthPredsR, postAuthPredsR :: Handler Html
 getAuthPredsR = postAuthPredsR
 postAuthPredsR = do

src/Handler/Utils/Table/Cells.hs

@@ -268,17 +268,13 @@ courseCell Course{..} = anchorCell link name `mappend` desc
               |]
 
 qualificationCell :: IsDBTable m a => Qualification -> DBCell m a
-qualificationCell Qualification{..} = anchorCell link name `mappend` desc
+qualificationCell Qualification{..} = anchorCell link name <> desc
   where
     link = QualificationR qualificationSchool qualificationShorthand
     name = citext2widget qualificationName
     desc = case qualificationDescription of
             Nothing      -> mempty
-            (Just descr) -> cell [whamlet|
+            (Just descr) -> spacerCell <> markupCellLargeModal descr
-              $newline never
-              <div>
-                ^{modal "Beschreibung" (Right $ toWidget descr)}
-              |]
 
 sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
 sheetCell crse shn =
@@ -323,4 +319,4 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
 
 qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
 qualificationBlockedCell Nothing   = mempty 
-qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)
+qualificationBlockedCell (Just qb) = msgCell qb <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell (qualificationBlockedDay qb)

src/Jobs/Crontab.hs

@@ -368,7 +368,7 @@ determineCrontab = execWriterT $ do
         { cronInitial   = CronAsap  -- time after scheduling 
         , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
                                                                 , cronMinute = cronMatchOne 3
-                                                                , cronSecond = cronMatchOne 2
+                                                                , cronSecond = cronMatchOne 27
                                                                 }
         , cronRateLimit = nominalDay / 2        -- minimal time between two executions, before the second job is skipped
         , cronNotAfter  = Left nominalDay       -- maximal delay of an execution, before it is skipped entirely
@@ -380,7 +380,7 @@ determineCrontab = execWriterT $ do
         { cronInitial   = CronAsap  -- time after scheduling 
         , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
                                                                 , cronMinute = cronMatchOne 33
-                                                                , cronSecond = cronMatchOne 2
+                                                                , cronSecond = cronMatchOne 27
                                                                 }
         , cronRateLimit = nominalDay / 2        -- minimal time between two executions, before the second job is skipped
         , cronNotAfter  = Left nominalDay       -- maximal delay of an execution, before it is skipped entirely

src/Jobs/Handler/LMS.hs

@@ -20,7 +20,7 @@ import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.Set as Set
 
-import Handler.Utils.DateTime 
+import Handler.Utils.DateTime
 import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
 
 import qualified Data.CaseInsensitive as CI
@@ -49,7 +49,7 @@ dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsEnqueue qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
-    act = do    
+    act = do
       quali <- getJust qid -- may throw an error, aborting the job
       let qshort = CI.original $ qualificationShorthand quali
       $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
@@ -85,13 +85,13 @@ dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
 dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
   where
     act :: YesodJobDB UniWorX ()
-    act = do      
+    act = do
-      identsInUseVs <- E.select $ do 
+      identsInUseVs <- E.select $ do
         lui <- E.from $
           ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) )
-          `E.union_` 
+          `E.union_`
           ( (E.^. LmsResultIdent)   <$> E.from (E.table @LmsResult) )
-          `E.union_` 
+          `E.union_`
           ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser) )
         E.orderBy [E.asc lui]
         pure lui
@@ -111,7 +111,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserEnded         = Nothing
             }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
-          startLmsUser = do 
+          startLmsUser = do
             pw <- randomLMSpw
             maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse)
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
@@ -124,14 +124,21 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
 
 -- purge LmsIdent adter QualificationAuditDuration expired
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsDequeue qid = JobHandlerAtomic act  
+dispatchJobLmsDequeue qid = JobHandlerAtomic act
   where
-    act = do      
+    act = do
       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 
+      -- TODO: notify expired used 
+          -- let nowaday = utctDay now
+          -- forM_ (E.unValue . snd <$> delusersVals) $ \uid ->
+          --   queueDBJob JobSendNotification
+          --     { jRecipient    = uid
+          --     , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
+          --     }
+      -- purge outdated LmsUsers
       case qualificationAuditDuration quali of
         Nothing -> return () -- no automatic removal
         (Just auditDuration) -> do
@@ -149,16 +156,14 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
                               E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
                         )
             pure (luser E.^. LmsUserIdent)
-          let delusers = E.unValue <$> delusersVals          
+          let delusers = E.unValue <$> delusersVals
-              numdel = length delusers
+              numdel = length delusers              
           when (numdel > 0) $ do
             $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 [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
             deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
-          
-
 
 -- processes received results and lengthen qualifications, if applicable
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
@@ -167,18 +172,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
       quali <- getJust qid
-      whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do 
+      whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do
-        -- otherwise there is nothing to do: we cannot renew s qualification  without a specified validDuration        
+        -- otherwise there is nothing to do: we cannot renew s qualification  without a specified validDuration
         -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
         results <- E.select $ do
           (quser E.:& luser E.:& lresult) <- E.from $
               E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
-              `E.innerJoin` E.table @LmsUser 
+              `E.innerJoin` E.table @LmsUser
-              `E.on` (\(quser E.:& luser) -> 
+              `E.on` (\(quser E.:& luser) ->
-                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser 
+                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
                         E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
-              `E.innerJoin` E.table @LmsResult 
+              `E.innerJoin` E.table @LmsResult
-              `E.on` (\(_ E.:& luser E.:& lresult) -> 
+              `E.on` (\(_ E.:& luser E.:& lresult) ->
                               luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
                         E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
           E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
@@ -186,10 +191,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
             E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result
             E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
           return (quser, luser, lresult)
-        now <- liftIO getCurrentTime                  
+        now <- liftIO getCurrentTime
         forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
           -- three separate DB operations per result is not so nice. All within one transaction though.
-          let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems        
+          let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
               lmsUserStartedDay = utctDay lmsUserStarted
               saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
                             && qualificationUserLastRefresh <= lmsUserStartedDay
@@ -202,7 +207,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
                           ]
               update luid [ LmsUserStatus   =. Just newStatus
                           , LmsUserReceived =. Just lmsResultTimestamp
-                          ]            
+                          ]
               return Nothing
             else do
               let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
@@ -210,8 +215,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
               return $ Just errmsg
 
           insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once
-          delete lrid      
+          delete lrid
-        $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] 
+        $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
 
 
 -- processes received input and block qualifications, if applicable
@@ -220,7 +225,7 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
   where
     act :: YesodJobDB UniWorX ()
     act = do
-      now <- liftIO getCurrentTime      
+      now <- liftIO getCurrentTime
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
         (luser E.:& lulist) <- E.from $
@@ -243,15 +248,21 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
               { jRecipient    = lmsUserUser luser
               , jNotification = NotificationQualificationRenewal { nQualification = qid }
               }
-            -- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
           let lReceived = lmsUserlistTimestamp lulist
-              isBlocked = lmsUserlistFailed lulist
+              isBlocked = lmsUserlistFailed    lulist
-          update luid [LmsUserReceived =. Just lReceived]
+          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotfied is only updated upon sending notifications
-          when isBlocked $ do 
+          $logInfoS "LmsUserlist" $ tshow lulist
-            let newStatus = LmsBlocked $ utctDay lReceived
+          when isBlocked $ do
-                oldStatus = lmsUserStatus luser
+            let blockedDay = utctDay lReceived
+                newStatus  = LmsBlocked blockedDay
+                oldStatus  = lmsUserStatus luser
             insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now
-            update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]          
+            update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
-            updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
+            updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms blockedDay)]
-          delete lulid 
+            queueDBJob JobSendNotification
+              { jRecipient    = lmsUserUser luser
+              , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }
+              }
+
+          delete lulid
       $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

src/Jobs/Handler/QueueNotification.hs

@@ -301,6 +301,7 @@ determineNotificationCandidates = awaitForever $ \notif -> do
            
            return (hasOverride, user)
     NotificationQualificationExpiry{}  -> return mempty  -- Not to be used with JobQueueNotification; recipients already known 
+    NotificationQualificationExpired{} -> return mempty  -- Not to be used with JobQueueNotification; recipients already known 
     NotificationQualificationRenewal{} -> return mempty  -- Not to be used with JobQueueNotification; recipients already known
     
 
@@ -339,4 +340,5 @@ classifyNotification NotificationSubmissionUserCreated{}          = return NTSub
 classifyNotification NotificationSubmissionUserDeleted{}          = return NTSubmissionUserDeleted
 classifyNotification NotificationAllocationNewCourse{}            = return NTAllocationNewCourse
 classifyNotification NotificationQualificationExpiry{}            = return NTQualification
+classifyNotification NotificationQualificationExpired{}           = return NTQualification
 classifyNotification NotificationQualificationRenewal{}           = return NTQualification

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -2,6 +2,7 @@
 
 module Jobs.Handler.SendNotification.Qualification
   ( dispatchNotificationQualificationExpiry
+  , dispatchNotificationQualificationExpired
   , dispatchNotificationQualificationRenewal
   ) where
 
@@ -22,16 +23,15 @@ import Text.Hamlet
 
 
 dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
-dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do
+dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,)
+  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
     <$> getJust jRecipient
-    <*> getJust nQualification
+    <*> getJust nQualification    
-    <*> getJustBy (UniqueQualificationUser nQualification jRecipient)
+
-  
   encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
-  expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
+  expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
 
   $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
 
@@ -43,6 +43,27 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
   addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
 
 
+dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler ()
+dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do
+  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
+    <$> getJust jRecipient
+    <*> getJust nQualification
+
+  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
+  let entRecipient = Entity jRecipient recipient
+      qname = CI.original qualificationName
+  expiryDate <- formatTimeUser SelFormatDate dExpired $ Just entRecipient
+
+  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname
+
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  setSubjectI $ MsgMailSubjectQualificationExpired qname
+
+  editNotifications <- mkEditNotifications jRecipient
+
+  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet")
+
+
 -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
@@ -51,8 +72,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
     <*> getJust nQualification
     <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
     <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
-  
+
-  encRecipient :: CryptoUUIDUser <- encrypt jRecipient 
+  encRecipient :: CryptoUUIDUser <- encrypt jRecipient
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
 
@@ -80,16 +101,16 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
                   , toMeta "url-text"       lmsUrl
                   , toMeta "url"            lmsLogin
                   ]
-      emailRenewal attachment 
+      emailRenewal attachment
-        | Text.null (CI.original userEmail) = do          -- if neither email nor postal address is known, we must abort! 
+        | Text.null (CI.original userEmail) = do          -- if neither email nor postal address is known, we must abort!
             let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
-            $logErrorS "LMS" msg 
+            $logErrorS "LMS" msg
             return False
         | otherwise = do
-            userMailT jRecipient $ do 
+            userMailT jRecipient $ do
               replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
               setSubjectI $ MsgMailSubjectQualificationRenewal qname
-              whenIsJust attachment $ \afile -> 
+              whenIsJust attachment $ \afile ->
                 addPart (File { fileTitle = Text.unpack fileName
                               , fileModified = now
                               , fileContent = Just $ yield $ LBS.toStrict afile
@@ -100,22 +121,22 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
 
   notifyOk <- pdfRenewal pdfMeta >>= \case
     Right pdf | userPrefersLetter recipient ->          -- userPrefersLetter is false if both userEmail and userPostAddress are null
-      let printSender  = Nothing 
+      let printSender  = Nothing
-      in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case        
+      in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case
         Left err -> do
-          let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err 
+          let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
           $logErrorS "LMS" msg
           return False
-        Right (msg,_) 
+        Right (msg,_)
           | null msg  -> return True
-          | otherwise -> do 
+          | otherwise -> do
               $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
               return True
 
     Right pdf -> do
-      attch <- case userPinPassword of 
+      attch <- case userPinPassword of
         Nothing   -> return $ Just pdf                  -- attach unencrypted, since there is no password set
-        Just passwd -> encryptPDF passwd pdf >>= \case 
+        Just passwd -> encryptPDF passwd pdf >>= \case
           Right encPdf -> return $ Just encPdf          -- attach encrypted
           Left err -> do                                -- send email without attachment, so that the user is at least notified about the expiry
             let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
@@ -127,6 +148,5 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
       let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
       $logErrorS "LMS" msg
       emailRenewal Nothing
-        
+
   when notifyOk $ runDB $ update luid [ LmsUserNotified =. Just now]
-    

src/Jobs/Types.hs

@@ -144,6 +144,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 }
   | NotificationQualificationRenewal { nQualification :: QualificationId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 

templates/mail/qualificationExpired.hamlet

@@ -0,0 +1,31 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{SomeMessage $ MsgMailSubjectQualificationExpired qname}
+
+    <p>
+      _{SomeMessage MsgMailBodyQualificationExpired}      
+
+    <p>
+      <dl>
+        <dt>_{SomeMessage MsgQualificationName}
+        <dd>
+          <a href=@{QualificationR qualificationSchool qualificationShorthand}>
+            #{qualificationName}
+        <dt>_{SomeMessage MsgLmsUser}
+        <dd>#{nameHtml userDisplayName userSurname}
+        <dt>_{SomeMessage MsgLmsQualificationValidUntil}
+        <dd>#{expiryDate}
+
+
+    ^{ihamletSomeMessage editNotifications}

templates/profileData.hamlet

@@ -146,6 +146,11 @@ $newline never
     <div .container>
       ^{enrolledCoursesTable}
 
+  <div .container>
+    <h2>_{MsgProfileQualifications}
+    <div .container>
+      ^{qualificationsTable}
+
   <div .container>
     <h2>_{MsgProfileCourseExamResults}
     <div .container>
@@ -171,7 +176,7 @@ $newline never
     <div .container>
       ^{submissionTable}
       <em>_{MsgProfileRemark}
-      _{MsgProfileGroupSubmissionDates}
+      \ _{MsgProfileGroupSubmissionDates}
 
   <div .container>
     <h2> _{MsgTableCorrector}
@@ -179,7 +184,7 @@ $newline never
       ^{correctionsTable}
 
     <em>_{MsgProfileRemark}
-    _{MsgProfileCorrectorRemark}
+    \ _{MsgProfileCorrectorRemark}
     <a href=@{CorrectionsR}>_{MsgProfileCorrections}
 
 ^{profileRemarks}

test/Database/Fill.hs

@@ -505,7 +505,9 @@ fillDb = do
   qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True
   qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3)  False
   qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True
-  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $   -1) (n_day $   -22) Nothing -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_r (n_day   99) (n_day $  -11) (n_day $  -222) (Just $ QualificationBlockedLms $ n_day $ -5)-- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_l (n_day  999) (n_day $ -111) (n_day $ -2222) Nothing -- TODO: better dates!
   void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) Nothing
   void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2) Nothing