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

fix(lms): LMS restart failing due to old LmsUser entry

Browse Source
This commit is contained in:
Steffen Jost 2023-11-15 12:42:04 +01:00
parent a360101d44
commit 6761767c6c
1 changed files with 21 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -142,6 +142,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
pure lui pure lui
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let identsInUse = Set.fromList (E.unValue <$> identsInUseVs) let identsInUse = Set.fromList (E.unValue <$> identsInUseVs)
uniqLmsUse = UniqueLmsQualificationUser qid uid
mkLmsUser lpin lid = LmsUser mkLmsUser lpin lid = LmsUser
{ lmsUserQualification = qid { lmsUserQualification = qid
, lmsUserUser = uid , lmsUserUser = uid
@ -157,26 +158,32 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
, lmsUserEnded = Nothing , lmsUserEnded = Nothing
, lmsUserResetTries = False , lmsUserResetTries = False
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
} }
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
startLmsUser = do startLmsUser = do
lpw <- randomLMSpw lpw <- randomLMSpw
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
-- runMaybeT $ do -- runMaybeT $ do
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser getBy uniqLmsUse >>= \case
case inserted of Just Entity{entityVal=LmsUser{..}}
Nothing -> do | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
uuid :: CryptoUUIDUser <- encrypt uid uuid :: CryptoUUIDUser <- encrypt uid
$logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
(Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified other -> do
audit $ TransactionLmsStart when (isJust other) $ deleteBy uniqLmsUse
{ transactionQualification = lqid untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
, transactionLmsIdent = lid Nothing -> do
, transactionLmsUser = luid uuid :: CryptoUUIDUser <- encrypt uid
, transactionLmsUserKey = lkey $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " for unknown reason!"
} (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified
audit $ TransactionLmsStart
{ transactionQualification = lqid
, transactionLmsIdent = lid
, transactionLmsUser = luid
, transactionLmsUserKey = lkey
}
-- purge LmsIdent after QualificationAuditDuration expired -- purge LmsIdent after QualificationAuditDuration expired