fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): implement report dispatch job DONE

Browse Source
This commit is contained in:
Steffen Jost 2023-08-25 12:35:21 +00:00
parent 12f4bcfa1b
commit 3085b8d91d
9 changed files with 105 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/lms.model
View File

@ -115,7 +115,7 @@ LmsUser
pin Text pin Text
resetPin Bool default=false -- should pin be reset? resetPin Bool default=false -- should pin be reset?
datePin UTCTime default=now() -- time pin was created datePin UTCTime default=now() -- time pin was created
status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS status LmsStatus Maybe -- Nothing=open, LmsSuccess, LmsBlocked or LmsExpired; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block
started UTCTime default=now() started UTCTime default=now()
@ -158,7 +158,7 @@ LmsReport
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
date Day Maybe -- BEWARE: timezone is local as submitted by LMS date Day Maybe -- BEWARE: timezone is local as submitted by LMS
result LmsState -- (0|1|2) 0=too many tries, 1=open, 2=success result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success]
lock Bool -- (0|1) lock Bool -- (0|1)
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsReport qualification ident -- required by DBTable UniqueLmsReport qualification ident -- required by DBTable

4
src/Handler/Admin/Avs.hs
View File

@ -446,7 +446,7 @@ getProblemAvsSynchR = do
then return (-1) then return (-1)
else do else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
qualificationUserBlocking licenceTableChangeFDriveQId uids False (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
@ -456,7 +456,7 @@ getProblemAvsSynchR = do
(n, Qualification{qualificationShorthand}) <- runDB $ do (n, Qualification{qualificationShorthand}) <- runDB $ do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True (Left licenceTableChangeFDriveReason) False void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId (length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n

2
src/Handler/LMS.hs
View File

@ -686,7 +686,7 @@ postLmsR sid qsh = do
numUsers = Set.size selectedUsers numUsers = Set.size selectedUsers
delUsers <- runDB $ do delUsers <- runDB $ do
when (lmsActRestartUnblock == Just True) $ do when (lmsActRestartUnblock == Just True) $ do
oks <- qualificationUserBlocking qid usersList True (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify) oks <- qualificationUserBlocking qid usersList True Nothing (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify)
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
whenIsJust lmsActRestartExtend $ \extDays -> do whenIsJust lmsActRestartExtend $ \extDays -> do

2
src/Handler/LMS/Learners.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later

2
src/Handler/LMS/Report.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later

4
src/Handler/Qualification.hs
View File

@ -610,7 +610,7 @@ postQualificationR sid qsh = do
formResult lmsRes $ \case formResult lmsRes $ \case
(QualificationActRenewData, selectedUsers) | isAdmin -> do (QualificationActRenewData, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
@ -639,7 +639,7 @@ postQualificationR sid qsh = do
oks <- runDB $ do oks <- runDB $ do
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
qualificationUserBlocking qid selUserIds unblock reason notify qualificationUserBlocking qid selUserIds unblock Nothing reason notify
let nrq = length selectedUsers let nrq = length selectedUsers
warnLevel = if warnLevel = if
| oks < 0 -> Error | oks < 0 -> Error

2
src/Handler/Tutorial/Users.hs
View File

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

88
src/Handler/Utils/Qualification.hs
View File

@ -118,7 +118,13 @@ validQualification' cutoff qualUser =
,qualUser E.?. QualificationUserValidUntil)) -- currently valid ,qualUser E.?. QualificationUserValidUntil)) -- currently valid
E.&&. quserBlock' False cutoff qualUser E.&&. quserBlock' False cutoff qualUser
selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser] -- selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications ::
( MonadIO m
, BackendCompatible SqlBackend backend
, PersistQueryRead backend
, PersistUniqueRead backend
) => QualificationId -> Maybe [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid mbUids cutoff = selectValidQualifications qid mbUids cutoff =
-- cutoff <- utctDay <$> liftIO getCurrentTime -- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do E.select $ do
@ -164,8 +170,21 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
} }
-- | Renew an existing valid qualification, ignoring all blocks otherwise -- | Renew an existing valid qualification, ignoring all blocks otherwise
renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int -- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
renewValidQualificationUsers qid uids = renewValidQualificationUsers ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
renewValidQualificationUsers qid renewalTime uids =
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
-- E.update $ \qu -> do -- E.update $ \qu -> do
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
@ -173,7 +192,7 @@ renewValidQualificationUsers qid uids =
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
get qid >>= \case get qid >>= \case
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
now <- liftIO getCurrentTime now <- maybe (liftIO getCurrentTime) return renewalTime
quEntsAll <- selectValidQualifications qid (Just uids) now quEntsAll <- selectValidQualifications qid (Just uids) now
let nowaday = utctDay now let nowaday = utctDay now
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
@ -207,47 +226,46 @@ qualificationUserBlocking ::
, MonadHandler m , MonadHandler m
, MonadCatch m , MonadCatch m
, Num n , Num n
) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
authUsr <- liftHandler maybeAuthId authUsr <- liftHandler maybeAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let blockTime = fromMaybe now mbBlockTime
-- -- Code would work, but problematic -- -- Code would work, but problematic
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
-- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
-- E.&&. quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa -- E.&&. quserBlock (not unblock) blockTime qualificationUser -- only unblock blocked qualification and vice versa
-- return $ QualificationUserBlock -- return $ QualificationUserBlock
-- E.<# qualificationUser E.^. QualificationUserId -- E.<# qualificationUser E.^. QualificationUserId
-- E.<&> E.val unblock -- E.<&> E.val unblock
-- E.<&> E.val nowaday -- E.<&> E.val blockTime
-- E.<&> E.val reason -- E.<&> E.val reason
-- E.<&> E.val authUsr -- E.<&> E.val authUsr
toChange' <- E.select $ do toChange <- E.select $ do
qualUser <- E.from $ E.table @QualificationUser qualUser <- E.from $ E.table @QualificationUser
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
E.&&. quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa E.&&. quserBlock (not unblock) blockTime qualUser -- only unblock blocked qualification and vice versa
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
let toChange = E.unValue . fst <$> toChange' let newBlocks = [ (quid, uid, qub)
E.insertMany_ $ map (\quid -> QualificationUserBlock | (E.Value quid, E.Value uid) <- toChange
{ qualificationUserBlockQualificationUser = quid , let qub = QualificationUserBlock
, qualificationUserBlockUnblock = unblock { qualificationUserBlockQualificationUser = quid
, qualificationUserBlockFrom = now , qualificationUserBlockUnblock = unblock
, qualificationUserBlockReason = reason , qualificationUserBlockFrom = blockTime
, qualificationUserBlockBlocker = authUsr , qualificationUserBlockReason = reason
}) toChange , qualificationUserBlockBlocker = authUsr
}
unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now] ]
E.insertMany_ (trd3 <$> newBlocks)
forM_ toChange' $ \(_, E.Value uid) -> do unless notify $ updateWhere [QualificationUserId <-. (fst3 <$> newBlocks)] [QualificationUserLastNotified =. now]
audit TransactionQualificationUserBlocking forM_ newBlocks $ \(_, uid, qub) -> audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid { transactionQualification = qid
transactionQualification = qid , transactionUser = uid
, transactionUser = uid , transactionQualificationBlock = qub
, transactionQualificationBlock = error "TODO" -- CONTINUE HERE }
} return $ fromIntegral $ length newBlocks
return $ fromIntegral $ length toChange
qualificationUserUnblockByReason :: qualificationUserUnblockByReason ::
( AuthId (HandlerSite m) ~ Key User ( AuthId (HandlerSite m) ~ Key User
@ -262,13 +280,13 @@ qualificationUserUnblockByReason ::
, MonadHandler m , MonadHandler m
, MonadCatch m , MonadCatch m
, Num n , Num n
) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
now <- liftIO getCurrentTime now <- maybe (liftIO getCurrentTime) return mbUnblockTime
toUnblock <- E.select $ do toUnblock <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
return $ quser E.^. QualificationUserUser return $ quser E.^. QualificationUserUser
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify

164
src/Jobs/Handler/LMS.hs
View File

@ -18,6 +18,7 @@ import Import
import Jobs.Queue import Jobs.Queue
-- import Jobs.Handler.Intervals.Utils -- import Jobs.Handler.Intervals.Utils
import Database.Persist.Sql (deleteWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E --import qualified Database.Esqueleto.Legacy as E
@ -25,6 +26,7 @@ import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Time.Zones as TZ import qualified Data.Time.Zones as TZ
import Handler.Utils.DateTime import Handler.Utils.DateTime
@ -238,10 +240,11 @@ dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
dispatchJobLmsReports qid = JobHandlerAtomic act dispatchJobLmsReports qid = JobHandlerAtomic act
where where
-- act :: YesodJobDB UniWorX () -- act :: YesodJobDB UniWorX ()
act = hoist lift $ do 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 now <- liftIO getCurrentTime
let today = utctDay now let today = utctDay now
locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
-- DB query for LmsUserUser, provided a matching LmsReport exists
luserQry luFltr repFltr = E.select $ do luserQry luFltr repFltr = E.select $ do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
@ -249,11 +252,12 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. luFltr luser E.&&. luFltr luser
E.&&. E.exists (do E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. repFltr luser lreport E.&&. repFltr luser lreport
) )
return $ luser E.^. LmsUserUser return $ luser E.^. LmsUserUser
-- DB query for LmsUser innerJoin LmsReport
lrepQry lrFltr = E.select $ do lrepQry lrFltr = E.select $ do
(luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
`E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent
@ -262,52 +266,34 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
E.&&. lrFltr luser lreport E.&&. lrFltr luser lreport
return (luser, lreport) return (luser, lreport)
-- group results by LmsReportDate
-- A) notify all newly reported users that lms is available grpRepByDay :: [(Entity LmsUser, Entity LmsReport)] -> Map.Map (Maybe Day) ([LmsUserId],[UserId])
-- newLearners <- E.select $ do grpRepByDay reps = Map.fromListWith (<>) [(lmsReportDate lreport, ([luid],[lmsUserUser luser])) | (Entity luid luser, Entity _ lreport) <- reps]
-- luser <- E.from $ E.table @LmsUser -- A) notify all newly reported users that lms is available
-- E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
-- E.&&. E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting
-- E.&&. E.exists (do
-- lreport <- E.from $ E.table @LmsReport
-- E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
-- )
-- return $ luser E.^. LmsUserUser
-- forM newLearners $ \(E.Value uid) ->
-- queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
in luserQry luserFltrNew E.true >>= mapM_ notifyNewLearner in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
-- B) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) -- B) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit)
let luserFltrBlock luser = let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
repFltrBlock in lrepQry lrFltrBlock >>= (\toBlock ->
in luserQry luserFltrBlock repFltrBlock >>= (\toBlock -> do void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do
let uidToBlock = E.unValue <$> toBlock void $ qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
void $ qualificationUserBlocking qid uidToBlock False (Right QualificationBlockFailedELearning) True updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)]
updateWhere [ LmsUserQualification ==. uid )
, LmsUserUser <-. uidToBlock -- C) renew qualifications for all successfull learners
, let lrFltrSuccess luser lreport = luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status
] in lrepQry lrFltrSuccess >>= (\toRenew ->
[ LmsUserStatus =. Just LmsBlocked void $ flip Map.traverseWithKey (grpRepByDay toRenew) $ \repDay (lids,uids) -> do
, LmsUserStatusDay =. Just ??? -- does not work! -- 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
) repTime = toMidnight <$> repDay
-- alternative attempt ok_unblock <- qualificationUserUnblockByReason qid uids repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
let lrFltrBlock luser lreport = E.isNothing (user E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed 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|])
in lrepQry lrFltrBlock >>= (\toBlock -> do -- END LMS WORKAROUND 2
let uidToBlock = (^. _1 . _entityVal . _lmsUserUser) <$> toBlock void $ renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log
void $ qualificationUserBlocking qid uidToBlock False (Right QualificationBlockFailedELearning) True updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)]
let blockDayGrps = Map.fromListWith (<>) [(lmsReportDate lreport, [luid]) | (Entity luid _, Entity _ lreport) <- toBlock]
blockLmsUsr bld luids = updateWhere [LmsUserQualification ==. uid, LmsUserId <-. luids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. bld <|> Just today]
void $ Map.traverseWithKey blockLmsUsr blockDayGrps
) )
let lrFltrSuccess luser lreport = (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult)
-- C) renew qualifications for all successfull learners
-- D) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) -- D) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
E.update $ \luser -> do E.update $ \luser -> do
E.set luser [ LmsUserEnded E.=. E.justVal now ] E.set luser [ LmsUserEnded E.=. E.justVal now ]
@ -316,19 +302,19 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
E.&&. E.notExists (do E.&&. E.notExists (do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
) )
-- E) lock expired learned? -- maybe move to dequeue? -- E) lock expired learneds: happens during JobLmsDequeue only
-- F) update lock and received -- F) update lock and received
let updateReceivedLocked lockstatus = E.update $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice let updateReceivedLocked lockstatus = E.update $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
E.set luser [ LmsUserReceived E.=. E.justVal now E.set luser [ LmsUserReceived E.=. E.justVal now
, lmsUserLocked E.=. E.val lockstatus ] , LmsUserLocked E.=. E.val lockstatus ]
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.exists (do E.&&. E.exists (do
lreport <- E.from $ E.table @LmsReport lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
) )
@ -344,76 +330,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) -- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
updateReceivedLocked False updateReceivedLocked False
updateReceivedLocked True updateReceivedLocked True
-- C) -- G) Truncate LmsReport for qid and log
-- load into memory all open learners that need to be processed -- TOO MUCH; SUBDIVIDE ALL CASES BEFORE QUERY repProc <- deleteWhereCount [LmsReportQualification ==. qid]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
{- CASE ANALYSIS:
1. LmsReportResult = LmsFailed && LmsUserStatus /= Just LmsBlocked -> Set to blocked
2. LmsReportResult = LmsOpen && LmsUserStatus /= Nothing -> What to do?
3. LmsReportResult = LmsPassed && LmsUserStatus /= Just LmsSuccess -> Always accept success?!
-}
results <- E.select $ do
(quser :& luser :& lreport) <- E.from $
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
`E.innerJoin` E.table @LmsUser
`E.on` (\(quser :& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
`E.innerJoin` E.table @LmsReport
`E.on` (\(_ :& luser :& lreport) ->
luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent
E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification)
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
E.&&. (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult)
E.&&. (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult)
-- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result -- workaround
return (quser, luser, lreport)
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsReport{..}) -> if
--
-- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsReportDate `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
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
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] (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}|])
_ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- 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
[ LmsUserStatus =. Just LmsSuccess
, LmsUserStatusDay =. Just lmsResultSuccess
, LmsUserReceived =. Just lmsResultTimestamp
]
return Nothing
else do
let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|]
$logErrorS "LMS" errmsg
return $ Just errmsg
audit TransactionLmsSuccess -- always log success, since this is only transmitted once
{ transactionQualification = qid
, transactionLmsIdent = lmsUserIdent
, transactionLmsDay = lmsResultSuccess
, transactionLmsUser = Just lmsUserUser
, transactionNote = note
, transactionReceived = lmsResultTimestamp
}
delete lrid
$logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]
-- DEPRECATED processes received results and lengthen qualifications, if applicable -- DEPRECATED processes received results and lengthen qualifications, if applicable
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
@ -449,10 +369,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
then do 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 -- 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: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (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}|]) when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
_ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- only unblocked are renewed _ok_renew <- renewValidQualificationUsers qid 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 -- 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 update luid
@ -517,7 +437,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
updateStatus = isBlocked && oldStatus /= Just LmsSuccess updateStatus = isBlocked && oldStatus /= Just LmsSuccess
when updateStatus $ do when updateStatus $ do
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay]
ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True
when (ok /= 1) $ do when (ok /= 1) $ do
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
$logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]