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

chore(lms): Fix #45 subsequent lms success also unblocks e-learning blocks

Browse Source
This commit is contained in:
Steffen Jost 2023-05-04 11:24:09 +00:00
parent a64a2368db
commit 56aa593c8d
2 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -154,11 +154,18 @@ qualificationUserUnblockByReason ::
, Num n
) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids reason = do
blockUsers <- selectList [ QualificationUserQualification ==. qid
, QualificationUserBlockedDue !=. Nothing
, QualificationUserUser <-. uids
] [Asc QualificationUserId]
let toUnblock = filter (\quent -> reason == quent ^. _entityVal . _qualificationUserBlockedDue . _qualificationBlockedReason) blockUsers
blockedUsers <- selectList [ QualificationUserQualification ==. qid
, QualificationUserBlockedDue !=. Nothing
, QualificationUserUser <-. uids
] [Asc QualificationUserId]
let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
[ QualificationUserBlockedDue =. Nothing ]
forM_ toUnblock $ \ubl -> do
audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid
transactionQualification = qid
, transactionUser = ubl ^. _entityVal . _qualificationUserUser
, transactionQualificationBlock = Nothing
}
return $ fromIntegral oks

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

@ -217,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
return (quser, luser, lresult)
now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
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 lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
@ -226,15 +226,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
-- 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
-- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
update quid [ QualificationUserBlockedDue =. Nothing ]
update luid
[ LmsUserStatus =. newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
-- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
-- update quid [ QualificationUserBlockedDue =. Nothing ]
return Nothing
else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]