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

fix(avs): avs background synchs and lms userlist result no longer block handler

Browse Source
This commit is contained in:
Steffen Jost 2023-07-07 11:32:59 +00:00
parent 6dc3d8d059
commit 0beb0e4011
7 changed files with 31 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Handler/Admin.hs
View File

@ -54,9 +54,8 @@ getAdminProblemsR = do
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
(Right AvsLicenceDifferences{..}) -> do
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-- mapM_ (queueJob' . flip JobSynchroniseAvsId cutOffAvsSynch) problemIds
runDBJobs . forM_ problemIds $ queueDBJob . flip JobSynchroniseAvsId (Just nowaday)
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
return $ Right
( Set.size avsLicenceDiffRevokeAll
, Set.size avsLicenceDiffGrantVorfeld

8
src/Handler/LMS.hs
View File

@ -671,15 +671,15 @@ postLmsR sid qsh = do
fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
runDBJobs $ forM_ selectedUsers $ \uid ->
queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
forM_ selectedUsers $ \uid ->
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
let numUsers = length selectedUsers
mStatus = bool Success Warning $ delUsers < numUsers
addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers
reloadKeepGetParams $ LmsR sid qsh
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
numExaminees <- runDBJobs $ do
numExaminees <- runDB $ do
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
, LmsUserEnded ==. Nothing -- not yet deleted
, LmsUserStatus ==. Nothing -- not yet decided
@ -690,7 +690,7 @@ postLmsR sid qsh = do
newPin <- liftIO randomLMSpw
update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True]
when (isNotifyAct action) $
queueDBJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
return $ length okUsers
let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees

10
src/Handler/LMS/Result.hs
View File

@ -212,7 +212,7 @@ postLmsResultR sid qsh = do
-- Direct File Upload/Download
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
saveResultCsv qid i LmsResultTableCsv{..} = do
now <- liftIO getCurrentTime
void $ upsert
@ -238,12 +238,12 @@ postLmsResultUploadR sid qsh = do
FormSuccess file -> do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
nr <- runDBJobs $ do
nr <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
queueDBJob $ JobLmsResults qid
queueJob' $ JobLmsResults qid
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsResultR sid qsh
@ -267,7 +267,7 @@ postLmsResultDirectR sid qsh = do
(status, msg) <- case files of
[(fhead,file)] -> do
lmsDecoder <- getLmsCsvDecoder
runDBJobs $ do
runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file
.| lmsDecoder
@ -279,7 +279,7 @@ postLmsResultDirectR sid qsh = do
Right nr -> do
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
$logInfoS "LMS" msg
when (nr > 0) $ queueDBJob $ JobLmsResults qid
when (nr > 0) $ queueJob' $ JobLmsResults qid
return (ok200, msg)
[] -> do
let msg = "Result upload file missing."

10
src/Handler/LMS/Userlist.hs
View File

@ -212,7 +212,7 @@ postLmsUserlistR sid qsh = do
-- Direct File Upload/Download
-- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
-- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
now <- liftIO getCurrentTime
void $ upsert
@ -236,10 +236,10 @@ postLmsUserlistUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeUserlistUploadForm
case result of
FormSuccess file -> do
nr <- runDBJobs $ do
nr <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
queueDBJob $ JobLmsUserlist qid
queueJob' $ JobLmsUserlist qid
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsUserlistR sid qsh
@ -263,7 +263,7 @@ postLmsUserlistDirectR sid qsh = do
(status, msg) <- case files of
[(fhead,file)] -> do
lmsDecoder <- getLmsCsvDecoder
runDBJobs $ do
runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file
.| lmsDecoder
@ -275,7 +275,7 @@ postLmsUserlistDirectR sid qsh = do
Right nr -> do
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
$logInfoS "LMS" msg
when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
when (nr > 0) $ queueJob' $ JobLmsUserlist qid
return (ok200, msg)
[] -> do
let msg = "Userlist upload file missing."

4
src/Handler/Users.hs
View File

@ -359,11 +359,11 @@ postUsersR = do
| Set.null usersSet && isNotSetSupervisor act ->
addMessageI Info MsgActionNoUsersSelected
(UserLdapSyncData, userSet) -> do
runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirectKeepGetParams UsersR
(UserAvsSyncData, userSet) -> do
runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseAvsUser uid Nothing
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) ->

22
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -22,24 +22,24 @@ import Jobs.Queue
import Handler.Utils.Avs
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- TODO: refactor so that the AvsIdLookup becomes obsolete
= JobHandlerAtomic . runConduit $
readUsers .| filterIteration .| sinkDBJobs
dispatchJobSynchroniseAvs numIterations epoch iteration pause
= JobHandlerException . runDB $ do
now <- liftIO getCurrentTime
todos <- runConduit $ readUsers .| filterIteration now .| sinkList
putMany todos
where
readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
readUsers :: ConduitT () UserId _ ()
readUsers = selectKeys [] []
filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
filterIteration :: UTCTime -> ConduitT UserId AvsSync _ ()
filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do
let
userIteration, currentIteration :: Integer
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
currentIteration = toInteger iteration `mod` toInteger numIterations
-- $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
guard $ userIteration == currentIteration
return $ JobSynchroniseAvsUser userId pause
guard $ userIteration == currentIteration
return $ AvsSync userId now pause
-- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
-- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do
@ -97,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
AvsInterfaceUnavailable -> return () -- ignore and retry later
AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS
otherExc -> throwM otherExc
)
)
-- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters)
dispatchJobSynchroniseAvsNext :: JobHandler UniWorX

4
src/Jobs/Queue.hs
View File

@ -152,7 +152,7 @@ sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
sinkDBJobs = C.mapM_ queueDBJob
runDBJobs :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
-- | Blocking! Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
--
-- Jobs get immediately executed if the transaction succeeds
runDBJobs act = do
@ -161,7 +161,7 @@ runDBJobs act = do
forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform
return ret
-- | Blocking!
runDBJobs' :: YesodJobDB UniWorX a -> DB a
runDBJobs' act = do
(ret, jIds) <- mapReaderT runWriterT act