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} +
+