diff --git a/src/OddJobs/ConfigBuilder.hs b/src/OddJobs/ConfigBuilder.hs index 07e9016..ee52cd5 100644 --- a/src/OddJobs/ConfigBuilder.hs +++ b/src/OddJobs/ConfigBuilder.hs @@ -68,6 +68,7 @@ mkConfig logger tname dbpool ccControl jrunner configOverridesFn = , cfgConcurrencyControl = ccControl , cfgJobType = defaultJobType , cfgDefaultJobTimeout = Seconds 600 + , cfgDeleteSuccessfulJobs = True } in cfg diff --git a/src/OddJobs/Job.hs b/src/OddJobs/Job.hs index 43d60b5..5938b1a 100644 --- a/src/OddJobs/Job.hs +++ b/src/OddJobs/Job.hs @@ -131,6 +131,7 @@ import Database.PostgreSQL.Simple.ToField as PGS (toField) class (MonadUnliftIO m, MonadBaseControl IO m) => HasJobRunner m where getPollingInterval :: m Seconds onJobSuccess :: Job -> m () + deleteSuccessfulJobs :: m Bool onJobFailed :: m [JobErrHandler] getJobRunner :: m (Job -> IO ()) getDbPool :: m (Pool Connection) @@ -169,9 +170,12 @@ logCallbackErrors jid msg action = catchAny action $ \e -> log LevelError $ LogT instance HasJobRunner RunnerM where getPollingInterval = cfgPollingInterval . envConfig <$> ask onJobFailed = cfgOnJobFailed . envConfig <$> ask + onJobSuccess job = do fn <- cfgOnJobSuccess . envConfig <$> ask logCallbackErrors (jobId job) "onJobSuccess" $ liftIO $ fn job + deleteSuccessfulJobs = cfgDeleteSuccessfulJobs . envConfig <$> ask + getJobRunner = cfgJobRunner . envConfig <$> ask getDbPool = cfgDbPool . envConfig <$> ask getTableName = cfgTableName . envConfig <$> ask @@ -387,8 +391,11 @@ runJob jid = do (flip catches) [Handler $ timeoutHandler job startTime, Handler $ exceptionHandler job startTime] $ do runJobWithTimeout lockTimeout job endTime <- liftIO getCurrentTime - deleteJob jid - let newJob = job{jobStatus=Success, jobLockedBy=Nothing, jobLockedAt=Nothing} + shouldDeleteJob <- deleteSuccessfulJobs + let newJob = job{jobStatus=Success, jobLockedBy=Nothing, jobLockedAt=Nothing, jobUpdatedAt = endTime} + if shouldDeleteJob + then deleteJob jid + else void $ saveJob newJob log LevelInfo $ LogJobSuccess newJob (diffUTCTime endTime startTime) onJobSuccess newJob pure () diff --git a/src/OddJobs/Types.hs b/src/OddJobs/Types.hs index b2b6978..74fddd7 100644 --- a/src/OddJobs/Types.hs +++ b/src/OddJobs/Types.hs @@ -334,6 +334,9 @@ data Config = Config -- | How long can a job run after which it is considered to be "crashed" and -- picked up for execution again , cfgDefaultJobTimeout :: Seconds + + -- | Should successful jobs be deleted from the queue to save on table space? + , cfgDeleteSuccessfulJobs :: Bool }