From 0beb0e4011745ea51906e018c53548bb2f6d978e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Jul 2023 11:32:59 +0000 Subject: [PATCH] fix(avs): avs background synchs and lms userlist result no longer block handler --- src/Handler/Admin.hs | 5 ++--- src/Handler/LMS.hs | 8 ++++---- src/Handler/LMS/Result.hs | 10 +++++----- src/Handler/LMS/Userlist.hs | 10 +++++----- src/Handler/Users.hs | 4 ++-- src/Jobs/Handler/SynchroniseAvs.hs | 22 +++++++++++----------- src/Jobs/Queue.hs | 4 ++-- 7 files changed, 31 insertions(+), 32 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 40f51677e..943748605 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 80eae5b68..34d20300e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6662d7574..aca551ab6 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -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." diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 407c7436e..cb8618b6d 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -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." diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ad3ab6ee1..92f9c4803 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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, _)) -> diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 96ae456df..bdc2a3aab 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -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 diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index d9b3e31f0..25df1337f 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -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