From ee5a79398f5cfdca9fd6173882b11ed020e3c81e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Mar 2025 18:24:17 +0100 Subject: [PATCH] chore(job): add sleep job for testing also show running job workers --- config/test-settings.yml | 4 ++- src/Handler/Admin/Crontab.hs | 44 +++++++++++++++++++------------ src/Jobs/Handler/SendTestEmail.hs | 16 +++++++++-- src/Jobs/Types.hs | 3 ++- 4 files changed, 46 insertions(+), 21 deletions(-) diff --git a/config/test-settings.yml b/config/test-settings.yml index 1d96f0802..5ec83701a 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -14,4 +14,6 @@ log-settings: destination: test.log auth-dummy-login: true -server-session-acid-fallback: true \ No newline at end of file +server-session-acid-fallback: true + +job-workers: 20 \ No newline at end of file diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 4f82a3c22..721bd0333 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -17,7 +17,7 @@ import Handler.Utils -- import Data.Aeson (fromJSON) -- import qualified Data.Aeson as Aeson -- import qualified Data.Aeson.Types as Aeson -import qualified Data.Aeson.Encode.Pretty as Pretty +import qualified Data.Aeson.Encode.Pretty as Pretty -- import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text @@ -37,13 +37,13 @@ import qualified Database.Esqueleto.Utils as E -- Number of minutes a job must have been locked already to allow forced deletion jobDeleteLockMinutes :: Int -jobDeleteLockMinutes = 3 +jobDeleteLockMinutes = 3 deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''CronNextMatch - + getAdminCrontabR :: Handler TypedContent getAdminCrontabR = do jState <- getsYesod appJobState @@ -64,7 +64,7 @@ getAdminCrontabR = do encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupCrontab) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton AdminCrontabR) Nothing (Just Nothing) Nothing - + siteLayoutMsg MsgHeadingAdminCrontab $ do setTitleI MsgHeadingAdminCrontab [whamlet| @@ -121,7 +121,7 @@ instance Finite JobTableAction nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''JobTableAction id -newtype JobTableActionData = ActJobDeleteData +newtype JobTableActionData = ActJobDeleteData { jobDeleteLocked :: Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -151,7 +151,7 @@ postAdminJobsR = do , sortable (Just "lock-instance") (i18nCell MsgTableJobLockInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe (stringCell . show) queuedJobLockInstance , sortable (Just "creation-instance") (i18nCell MsgTableJobCreationInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> stringCell $ show queuedJobCreationInstance ] - dbtSorting = Map.fromList + dbtSorting = Map.fromList [ ("creation-time" , SortColumnNullsInv (E.^. QueuedJobCreationTime)) , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) , ("content" , SortColumn (E.^. QueuedJobContent)) @@ -171,8 +171,8 @@ postAdminJobsR = do acts :: Map JobTableAction (AForm Handler JobTableActionData) acts = Map.singleton ActJobDelete $ ActJobDeleteData <$> areq checkBoxField (fslI $ MsgActJobDeleteForce jobDeleteLockMinutes) Nothing - dbtParams = DBParamsForm - { dbParamsFormAdditional = + dbtParams = DBParamsForm + { dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing @@ -188,14 +188,15 @@ postAdminJobsR = do dbtCsvDecode = Nothing dbtExtraReps = [] -- jobsDBTableValidator :: PSValidator (MForm Handler) (FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))) - jobsDBTableValidator = def + jobsDBTableValidator = def & defaultSorting [SortDescBy "creation-time"] - postprocess :: FormResult (First JobTableActionData, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) + postprocess :: FormResult (First JobTableActionData, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) -> FormResult (JobTableActionData, Set QueuedJobId) - postprocess inp = do + postprocess inp = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) + void . queueJob' $ JobSleep 42 -- debug add sleep job (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable) formResult jobActRes $ \case @@ -205,24 +206,33 @@ postAdminJobsR = do cutoff = addUTCTime (nominalMinute * fromIntegral (negate jobDeleteLockMinutes)) now jobReq = length jobIds lockCriteria - | jobDeleteLocked = + | jobDeleteLocked = [ QueuedJobLockTime ==. Nothing ] ||. [ QueuedJobLockTime <=. Just cutoff ] - | otherwise = + | otherwise = [ QueuedJobLockTime ==. Nothing , QueuedJobLockInstance ==. Nothing ] rmvd <- runDB $ fromIntegral <$> deleteWhereCount ((QueuedJobId <-. Set.toList jobIds) : lockCriteria) - + addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq) reloadKeepGetParams AdminJobsR + -- gather some data on job worles + (nrWorkers, jobStateVar) <- getsYesod (view _appJobWorkers &&& appJobState) + jState <- atomically $ tryReadTMVar jobStateVar + let running = Map.size . jobWorkers <$> jState siteLayoutMsg MsgMenuAdminJobs $ do setTitleI MsgMenuAdminJobs [whamlet| - ^{jobsTable} +
+ ^{jobsTable} +
+
    +
  • #{running} job workers currently running +
  • #{nrWorkers} job workers configured to run |] where doEnc :: ToJSON a => a -> _ @@ -232,8 +242,8 @@ postAdminJobsR = do , Text.splitOn "-" t ) } - + getJobName :: Value -> Maybe Text - getJobName (Object o) + getJobName (Object o) | Just (String s) <- HashMap.lookup "job" o = Just s -- (kebabToCamel s) getJobName _ = Nothing \ No newline at end of file diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 096b3b7ab..77b53db23 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -4,6 +4,7 @@ module Jobs.Handler.SendTestEmail ( dispatchJobSendTestEmail + , dispatchJobSleep ) where import Import @@ -14,6 +15,8 @@ import Text.Hamlet -- import Handler.Utils.I18n -- import Text.Blaze.Internal +import UnliftIO.Concurrent (threadDelay) + dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do _mailTo .= [Address Nothing jEmail] @@ -58,6 +61,15 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail --test <- liftHandler $ withUrlRenderer $(i18nHamletFile "test") test :: Html <- liftHandler $ withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet") addHtmlMarkdownAlternatives test - -- + -- --test2 <- liftHandler $(i18nHamletFile "test") - --addHtmlMarkdownAlternatives test2 \ No newline at end of file + --addHtmlMarkdownAlternatives test2 + + +dispatchJobSleep :: Int -> JobHandler UniWorX +dispatchJobSleep sleepTime = JobHandlerAtomic act + where + act = do + $logInfoS "JOBS" [st|Sleep job #{sleepTime}s started.|] + threadDelay (sleepTime * 1000000) + $logInfoS "JOBS" [st|Sleep job #{sleepTime}s ended.|] \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 7b7ddd5e7..fe18322db 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -141,8 +141,9 @@ data Job | JobLmsReports { jQualification :: QualificationId } | JobPrintAck | JobPrintAckAgain - + | JobSleep { jSleep :: Int } -- dummy job that just sleeps to test job system deriving (Eq, Ord, Show, Read, Generic) + data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId }