Merge branch 'master' into fradrive/company

CHANGELOG.md

@@ -2,6 +2,23 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07)
+
+
+### Bug Fixes
+
+* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d))
+
+## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03)
+
+## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03)
+
+
+### Bug Fixes
+
+* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77))
+* **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e))
+
 ## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
 
 

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

@@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls
 QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
 QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
 QualificationGrantReason: Erteilungsbegründung
+QualificationRenewReason: Verlängerungsbegründung
 QualificationBlockReason: Entzugsbegründung
 QualificationBlockNotify: Benachrichtigung verschicken
 QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen

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

@@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Will there be a notification, if this quali
 QualificationUserNoRenewal: Expires without further notification
 QualificationUserNone: No registered qualifications for this person.
 QualificationGrantReason: Reason for granting
+QualificationRenewReason: Reason for renewal
 QualificationBlockReason: Reason for revoking
 QualificationBlockNotify: Send notification
 QualificationBlockRemoveSupervisor: Remove all supervisors

models/lms.model

@@ -144,7 +144,7 @@ LmsUser
 --   UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
 --   deriving Generic
 
--- LmsUserlist stores LMS upload for later processing only
+-- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only
 LmsUserlist
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent        
@@ -153,7 +153,7 @@ LmsUserlist
   UniqueLmsUserlist qualification ident
   deriving Generic Show
 
--- LmsResult stores LMS upload for later processing only
+-- DEPRECATED V1 LmsResult stores LMS upload for later processing only
 LmsResult
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent        
@@ -162,6 +162,7 @@ LmsResult
   UniqueLmsResult qualification ident -- required by DBTable
   deriving Generic
 
+-- V2 Stores LMS upload for processing in Background Job
 LmsReport
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent
@@ -170,4 +171,16 @@ LmsReport
   lock              Bool            -- (0|1)
   timestamp         UTCTime         default=now()
   UniqueLmsReport qualification ident -- required by DBTable
+  deriving Generic
+
+-- LmsAudit removed by commit 71cde92a
+-- due to frequent transmit errors, a separate lms tranmission log is necessary again
+LmsReportLog
+  qualification     QualificationId OnDeleteCascade OnUpdateCascade
+  ident             LmsIdent
+  date              UTCTime Maybe   -- BEWARE: timezone is local as submitted by LMS
+  result            LmsState        -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success]
+  lock              Bool            -- (0|1)
+  timestamp         UTCTime         default=now()  
+  missing           Bool            default=false
   deriving Generic

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.45"
+  "version": "27.4.48"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.45",
+  "version": "27.4.48",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.45",
+  "version": "27.4.48",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.45
+version: 27.4.48
 dependencies:
   - base
   - yesod

src/Audit/Types.hs

@@ -216,6 +216,7 @@ data Transaction
     , transactionQualification                :: QualificationId    
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
+    , transactionNote                         :: Maybe Text
     }
   | TransactionQualificationUserDelete
     { transactionUser               :: UserId

src/Handler/Qualification.hs

@@ -296,7 +296,7 @@ data QualificationTableActionData
   | QualificationActBlockSupervisorData
   | QualificationActBlockData           { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
   | QualificationActUnblockData         { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
-  | QualificationActRenewData
+  | QualificationActRenewData           { qualTableActChangeReason :: Text}
   | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
   deriving (Eq, Ord, Show, Generic)  
 
@@ -573,7 +573,8 @@ postQualificationR sid qsh = do
               <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason)             Nothing
               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockRemoveSupervisor)  (Just False)
-          , singletonMap QualificationActRenew           $ pure QualificationActRenewData
+          , singletonMap QualificationActRenew           $      QualificationActRenewData
+              <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationRenewReason)             Nothing
           , singletonMap QualificationActGrant           $      QualificationActGrantData 
                 <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
                 <*  aformMessage msgGrantWarning
@@ -608,8 +609,8 @@ postQualificationR sid qsh = do
     return (tbl, qent)
   
   formResult lmsRes $ \case
-    (QualificationActRenewData, selectedUsers) | isAdmin -> do
+    (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
-      noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers      
+      noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers      
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      

src/Handler/Tutorial/Users.hs

@@ -146,7 +146,7 @@ postTUsersR tid ssh csh tutn = do
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
-        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers      
+        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers      
         addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do

src/Handler/Utils/Qualification.hs

@@ -24,10 +24,10 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati
 
 
 -- needs refactoring, probbably no longer helpful
-mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
+mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
 mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
    where 
-     qualificationUserBlockReason = qualificationBlockedReasonText reason    
+     qualificationUserBlockReason  = tshow reason    
      qualificationUserBlockUnblock = False 
      qualificationUserBlockBlocker = Nothing
 
@@ -158,6 +158,7 @@ upsertQualificationUser  qualificationUserQualification startTime qualificationU
     , transactionUser                         = qualificationUserUser
     , transactionQualificationValidUntil      = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
+    , transactionNote                         = canonical $ Just reason
     }
 
 -- | Renew an existing valid qualification, ignoring all blocks otherwise
@@ -174,8 +175,8 @@ renewValidQualificationUsers ::
   , HasAppSettings (HandlerSite m)
   , MonadHandler m
   , MonadCatch m  
-  ) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
+  ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
-renewValidQualificationUsers qid renewalTime uids =
+renewValidQualificationUsers qid reason renewalTime uids =
   -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
   -- E.update $ \qu -> do
   --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
@@ -199,6 +200,7 @@ renewValidQualificationUsers qid renewalTime uids =
           , transactionUser                         = qualificationUserUser
           , transactionQualificationValidUntil      = newValidTo
           , transactionQualificationScheduleRenewal = Nothing
+          , transactionNote                         = qualificationChangeReasonText <$> reason
           }
       return $ length quEnts
     _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
@@ -217,8 +219,8 @@ qualificationUserBlocking ::
   , MonadHandler m
   , MonadCatch m
   , Num n
-  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
+qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
   $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
   authUsr <- liftHandler maybeAuthId
   now <- liftIO getCurrentTime
@@ -269,8 +271,8 @@ qualificationUserUnblockByReason ::
   , MonadHandler m
   , MonadCatch m
   , Num n
-  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
+qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
   cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime 
   toUnblock <- E.select $ do
     quser <- E.from $ E.table @QualificationUser

src/Jobs/Handler/LMS.hs

@@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
             -- runMaybeT $ do
             --   lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
-            --   MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid                            
+            --   MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of
         Nothing  -> do
@@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
       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      
+      now <- liftIO getCurrentTime
       -- end users that expired by doing nothing
       expiredUsers <- E.select $ do
           (quser :& luser) <- E.from $
@@ -201,9 +201,10 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
               -- E.&&.  E.isNothing (luser E.^. LmsUserStatus)
               -- E.&&.  E.isNothing (luser E.^. LmsUserEnded)
               E.&&.  E.not_ (validQualification now quser)
-          pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId)
+          pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
-      nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
+      nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
-      let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers]
+      let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
+      -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
       nrExpired <- E.updateCount $ \luser -> do
         E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
         E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
@@ -213,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
 
       when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
         notifyInvalidDrivers <- E.select $ do
-            (quser :& qblock) <- E.from $ 
+            (quser :& qblock) <- E.from $
               E.table @QualificationUser
               `E.leftJoin` E.table @QualificationUserBlock
               `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
@@ -256,6 +257,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
             deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
             deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
             -- deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
+          deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
 
 
 dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
@@ -265,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
     act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
       now <- liftIO getCurrentTime
       -- DEBUG 2rows; remove later
-      totalrows <- count [LmsReportQualification ==. qid]      
+      totalrows <- count [LmsReportQualification ==. qid]
       $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
       when (totalrows > 0) $ do
         let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now  -- no longer necessary, since LMS reports dates only
@@ -291,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
                 E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
                 E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
                 E.&&. lrFltr luser lreport
-              return (luser, lreport)          
+              return (luser, lreport)
         -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
         E.update $ \luser -> do
           E.set luser [ LmsUserStatus     E.=. E.nothing
@@ -314,27 +316,28 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
           in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
         -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
         let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
-            procBlock (Entity luid luser, Entity _ lreport) = do 
+            procBlock (Entity luid luser, Entity _ lreport) = do
                 let repDay = lmsReportDate lreport <|> Just now
-                ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
+                ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
                 update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
                 return $ Sum ok_block
-          in lrepQry lrFltrBlock 
+          in lrepQry lrFltrBlock
-                >>= foldMapM procBlock 
+                >>= foldMapM procBlock
                 >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
         -- D) renew qualifications for all successfull learners
         let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
             procRenew (Entity luid luser, Entity _ lreport) = do
                 let repDay = lmsReportDate lreport <|> Just now
+                    reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
                 -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-                -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning                  
+                -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
                 -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
                 -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
                 -- END LMS WORKAROUND 2
-                ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
+                ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
                 update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
                 return $ Sum ok_renew
-          in lrepQry lrFltrSuccess 
+          in lrepQry lrFltrSuccess
                 >>= foldMapM procRenew
                 >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
         -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
@@ -377,7 +380,50 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
           >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
         updateReceivedLocked True
           >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
-        -- G) Truncate LmsReport for qid and log
+        -- G) Truncate LmsReport for qid, after updating log
+        E.insertSelect $ do
+          lreport <- E.from $ E.table @LmsReport
+          let samelog = E.subSelect $ do
+                  lrl <- E.from $ E.table @LmsReportLog
+                  E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid
+                      E.&&.  lrl E.^. LmsReportLogIdent         E.==. lreport E.^. LmsReportIdent
+                  E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
+                  return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
+                    E.&&.  lreport E.^. LmsReportLock   E.==. lrl E.^. LmsReportLogLock
+                    E.&&.  E.not_ (lrl E.^. LmsReportLogMissing)
+          E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
+              E.&&. E.not_ (E.isTrue samelog)
+          return (LmsReportLog
+            E.<#  (lreport E.^. LmsReportQualification)
+            E.<&> (lreport E.^. LmsReportIdent        )
+            E.<&> (lreport E.^. LmsReportDate         )
+            E.<&> (lreport E.^. LmsReportResult       )
+            E.<&> (lreport E.^. LmsReportLock         )
+            E.<&> (lreport E.^. LmsReportTimestamp    )
+            E.<&> E.false)
+        E.insertSelect $ do
+          lrl <- E.from $ E.table @LmsReportLog
+          E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
+                E.&&. lrl E.^. LmsReportLogQualification            E.==. E.val qid
+                E.&&. E.notExists (do
+                  lreport <- E.from $ E.table @LmsReport
+                  E.where_ $ lreport E.^. LmsReportQualification    E.==. E.val qid
+                      E.&&.  lreport E.^. LmsReportIdent            E.==. lrl E.^. LmsReportLogIdent
+                )
+                E.&&. E.notExists (do
+                  lrl_old <- E.from $ E.table @LmsReportLog
+                  E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid
+                    E.&&.    lrl_old E.^. LmsReportLogIdent         E.==. lrl E.^. LmsReportLogIdent
+                    E.&&.    lrl_old E.^. LmsReportLogTimestamp     E.>.  lrl E.^. LmsReportLogTimestamp
+                  )
+          return (LmsReportLog
+            E.<#  (lrl E.^. LmsReportLogQualification)
+            E.<&> (lrl E.^. LmsReportLogIdent        )
+            E.<&> E.nothing
+            E.<&> (lrl E.^. LmsReportLogResult       )
+            E.<&> (lrl E.^. LmsReportLogLock         )
+            E.<&> E.val now
+            E.<&> E.true)
         repProc <- deleteWhereCount [LmsReportQualification ==. qid]
         $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
 
@@ -415,11 +461,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
           note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
             then do
               -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-              let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
+              let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent)
-              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
+              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log
               when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
 
-              _ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed
+              _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed
               -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
 
               update luid
@@ -469,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
           | otherwise -> return ()                     -- users likely not yet started
 
         (Entity luid luser, Just (Entity _lulid lulist)) -> do
-          let lReceived = lmsUserlistTimestamp lulist              
+          let lReceived = lmsUserlistTimestamp lulist
           update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
 
           when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available

src/Model/Migration/Definitions.hs

@@ -139,7 +139,8 @@ migrateManual = do
     , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
     , ("idx_qualification_user_block_from"   ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")    
     , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
-    , ("idx_user_avs_card_person_id"         ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")    
+    , ("idx_user_avs_card_person_id"         ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
+    , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
     ]
   where
     addIndex :: Text -> Sql -> Migration

src/Model/Types/Lms.hs

@@ -12,8 +12,8 @@ module Model.Types.Lms
   ) where
 
 import Import.NoModel
-import qualified Data.Map as Map
+-- import qualified Data.Map as Map
-import Data.Map ((!))
+-- import Data.Map ((!))
 import Database.Persist.Sql 
 import qualified Database.Esqueleto.Experimental as E
 import qualified Data.Csv as Csv
@@ -56,27 +56,37 @@ instance Csv.ToField LmsStatus where
 
 
 -- | Default Block/Unblock reasons
-data QualificationBlockStandardReason
+data QualificationStandardReason
-      = QualificationBlockFailedELearning
+      = QualificationRenewELearningBy       LmsIdent
+      | QualificationBlockFailedELearningBy LmsIdent
+      | QualificationBlockFailedELearning      
       | QualificationBlockReturnedByCompany
       | QualificationBlockExpired
-  deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
+      
+  -- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
 
-instance Show QualificationBlockStandardReason where
+instance Show QualificationStandardReason where
-  show QualificationBlockFailedELearning    = "E-Learning durchgefallen"
+  show (QualificationRenewELearningBy       lid) = "E-Learning bestanden für "     <> show lid
-  show QualificationBlockReturnedByCompany  = "Rückgabe Firma"
+  show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
-  show QualificationBlockExpired            = "Abgelaufen"
+  show  QualificationBlockFailedELearning        = "E-Learning durchgefallen"  
-
+  show  QualificationBlockReturnedByCompany      = "Rückgabe Firma"
-qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
+  show  QualificationBlockExpired                = "Abgelaufen"
+  
+{-
+qualificationBlockedReasonText :: QualificationStandardReason -> Text
 qualificationBlockedReasonText = 
-  let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
+  let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
   in (dictionary !) -- cannot fail due to universeF
 
-type QualificationBlockReason = Either Text QualificationBlockStandardReason
+qualificationBlockedReasonText :: QualificationStandardReason -> Text
+qualificationBlockedReasonText = tshow
+-}
 
-qualificationBlockReasonText :: QualificationBlockReason -> Text
+type QualificationChangeReason = Either Text QualificationStandardReason
-qualificationBlockReasonText (Left     reason) = reason
+
-qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason
+qualificationChangeReasonText :: QualificationChangeReason -> Text
+qualificationChangeReasonText (Left     reason) = reason
+qualificationChangeReasonText (Right stdreason) = tshow stdreason
 
 -- | LMS interface requires Bool to be encoded by 0 or 1 only
 newtype LmsBool = LmsBool { lms2bool :: Bool }