6482f2f · odd-jobs · git.iko.soy

git.iko.soy/odd-jobs

on master help sign in

Follow hlint suggestion: redundant bracket.

6482f2fPhil de Joux4 years ago

.hlint.yaml−1

compare with master

unifiedsplit

@@ -1,7 +1,6 @@

1# Warnings currently triggered by your code

2- ignore: {name: "Eta reduce"} # 6 hints

3- ignore: {name: "Move brackets to avoid $"} # 19 hints

4−- ignore: {name: "Redundant bracket"} # 118 hints

5- ignore: {name: "Redundant if"} # 1 hint

4- ignore: {name: "Redundant if"} # 1 hint

6- ignore: {name: "Use newtype instead of data"} # 1 hint

5- ignore: {name: "Use newtype instead of data"} # 1 hint

7- ignore: {name: "Use null"} # 3 hints

6- ignore: {name: "Use null"} # 3 hints

examples/OddJobsCliExample.lhs+1−1

@@ -71,7 +71,7 @@ In this example, the core job-runner function is in the `IO` monad. In all proba

71\begin{code}

72myJobRunner :: Job -> IO ()

73myJobRunner job = do

74− (throwParsePayload job) >>= \case

74+ throwParsePayload job >>= \case

75 SendWelcomeEmail _userId -> do

76 putStrLn $ "This should call the function that actually sends the welcome email. " <>

77 "\nWe are purposely waiting 60 seconds before completing this job so that graceful shutdown can be demonstrated."

src/OddJobs/Cli.hs+5−5

@@ -164,12 +164,12 @@ defaultStopCommand :: StopArgs

164defaultStopCommand StopArgs{..} = do

165 progName <- getProgName

166 -- pid <- read <$> (readFile shutPidFile)

167− if (shutTimeout == Seconds 0)

167+ if shutTimeout == Seconds 0

168 then Daemon.brutalKill shutPidFile

169 else do putStrLn $ "Sending sigINT to " <> show progName <>

170 " and waiting " <> (show $ unSeconds shutTimeout) <> " seconds for graceful stop"

171 readFile shutPidFile >>= Sig.signalProcess Sig.sigINT . read

172− (Async.race (delaySeconds shutTimeout) checkProcessStatus) >>= \case

172+ Async.race (delaySeconds shutTimeout) checkProcessStatus >>= \case

173 Right _ -> do

174 putStrLn $ progName <> " seems to have exited gracefully."

175 Exit.exitSuccess

@@ -204,7 +204,7 @@ data Args = Args

204

205-- | The top-level command-line parser

206argParser :: CliType -> Parser Args

207−argParser cliType = Args <$> (commandParser cliType)

207+argParser cliType = Args <$> commandParser cliType

208

209-- ** Top-level command parser

210

@@ -261,7 +261,7 @@ startCmdParser cliType = Start

261 <*> (case cliType of

262 CliOnlyJobRunner _ -> pure Nothing

263 CliOnlyWebUi _ -> Just <$> uiStartArgsParser

264− CliBoth _ _ -> (Just <$> uiStartArgsParser) <|> (pure Nothing)

264+ CliBoth _ _ -> (Just <$> uiStartArgsParser) <|> pure Nothing

265 )

266

267data WebUiAuth

@@ -342,7 +342,7 @@ defaultCliParserPrefs = prefs $

342

343defaultCliInfo :: CliType -> ParserInfo Args

344defaultCliInfo cliType =

345− info ((argParser cliType) <**> helper) fullDesc

345+ info (argParser cliType <**> helper) fullDesc

346

347-- defaultDaemonOptions :: DaemonOptions

348-- defaultDaemonOptions = DaemonOptions

src/OddJobs/ConfigBuilder.hs+13−13

@@ -66,15 +66,15 @@ mkConfig :: (LogLevel -> LogEvent -> IO ())

66mkConfig logger tname dbpool ccControl jrunner configOverridesFn =

67 let cfg = configOverridesFn $ Config

68 { cfgPollingInterval = defaultPollingInterval

69− , cfgOnJobSuccess = (const $ pure ())

69+ , cfgOnJobSuccess = const $ pure ()

70 , cfgOnJobFailed = []

71 , cfgJobRunner = jrunner

72 , cfgLogger = logger

73 , cfgDbPool = dbpool

74− , cfgOnJobStart = (const $ pure ())

74+ , cfgOnJobStart = const $ pure ()

75 , cfgDefaultMaxAttempts = 10

76 , cfgTableName = tname

77− , cfgOnJobTimeout = (const $ pure ())

77+ , cfgOnJobTimeout = const $ pure ()

78 , cfgConcurrencyControl = ccControl

79 , cfgJobType = defaultJobType

80 , cfgDefaultJobTimeout = Seconds 600

@@ -111,7 +111,7 @@ mkUIConfig logger tname dbpool configOverridesFn =

111 , uicfgTableName = tname

112 , uicfgJobType = defaultJobType

113 , uicfgJobToHtml = defaultJobsToHtml (uicfgJobType cfg)

114− , uicfgAllJobTypes = (defaultDynamicJobTypes (uicfgTableName cfg) (uicfgJobTypeSql cfg))

114+ , uicfgAllJobTypes = defaultDynamicJobTypes (uicfgTableName cfg) (uicfgJobTypeSql cfg)

115 , uicfgJobTypeSql = defaultJobTypeSql

116 }

117 in cfg

@@ -140,7 +140,7 @@ defaultLogStr jobTypeFn logLevel logEvent =

140 FailPermanent -> "Failed (permanent)"

141 in tag <> " | " <> jobToLogStr j <> " | runtime=" <> (toLogStr $ show t) <> " | error=" <> (toLogStr $ show e)

142 LogJobSuccess j t ->

143− "Success | " <> (jobToLogStr j) <> " | runtime=" <> (toLogStr $ show t)

143+ "Success | " <> jobToLogStr j <> " | runtime=" <> (toLogStr $ show t)

144 LogJobTimeout j@Job{jobLockedAt, jobLockedBy} ->

145 "Timeout | " <> jobToLogStr j <> " | lockedBy=" <> (toLogStr $ maybe "unknown" unJobRunnerName jobLockedBy) <>

146 " lockedAt=" <> (toLogStr $ maybe "unknown" show jobLockedAt)

@@ -288,14 +288,14 @@ withConnectionPool connConfig action = withRunInIO $ \runInIO -> do

288 case connConfig of

289#if MIN_VERSION_resource_pool(0,3,0)

290 Left connString ->

291− newPool $ PoolConfig (PGS.connectPostgreSQL connString) PGS.close (fromIntegral $ 2 * (unSeconds defaultPollingInterval)) 8

291+ newPool $ PoolConfig (PGS.connectPostgreSQL connString) PGS.close (fromIntegral $ 2 * unSeconds defaultPollingInterval) 8

292 Right connInfo ->

293− newPool $ PoolConfig (PGS.connect connInfo) PGS.close (fromIntegral $ 2 * (unSeconds defaultPollingInterval)) 8

293+ newPool $ PoolConfig (PGS.connect connInfo) PGS.close (fromIntegral $ 2 * unSeconds defaultPollingInterval) 8

294#else

295 Left connString ->

296− createPool (PGS.connectPostgreSQL connString) PGS.close 1 (fromIntegral $ 2 * (unSeconds defaultPollingInterval)) 8

296+ createPool (PGS.connectPostgreSQL connString) PGS.close 1 (fromIntegral $ 2 * unSeconds defaultPollingInterval) 8

297 Right connInfo ->

298− createPool (PGS.connect connInfo) PGS.close 1 (fromIntegral $ 2 * (unSeconds defaultPollingInterval)) 8

298+ createPool (PGS.connect connInfo) PGS.close 1 (fromIntegral $ 2 * unSeconds defaultPollingInterval) 8

299#endif

300

301-- | A convenience function to help you define a timed-logger with some sensible

@@ -308,8 +308,8 @@ defaultTimedLogger :: FLogger.TimedFastLogger

308defaultTimedLogger logger logStrFn logLevel logEvent =

309 if logLevel == LevelDebug

310 then pure ()

311− else logger $ \t -> (toLogStr t) <> " | " <>

311+ else logger $ \t -> toLogStr t <> " | " <>

312− (logStrFn logLevel logEvent) <>

312+ logStrFn logLevel logEvent <>

313 "\n"

314

315

@@ -318,7 +318,7 @@ defaultJsonLogEvent logEvent =

318 case logEvent of

319 LogJobStart job ->

320 Aeson.object [ "tag" Aeson..= ("LogJobStart" :: Text)

321− , "contents" Aeson..= (defaultJsonJob job) ]

321+ , "contents" Aeson..= defaultJsonJob job ]

322 LogJobSuccess job runTime ->

323 Aeson.object [ "tag" Aeson..= ("LogJobSuccess" :: Text)

324 , "contents" Aeson..= (defaultJsonJob job, runTime) ]

@@ -327,7 +327,7 @@ defaultJsonLogEvent logEvent =

327 , "contents" Aeson..= (defaultJsonJob job, show e, defaultJsonFailureMode fm, runTime) ]

328 LogJobTimeout job ->

329 Aeson.object [ "tag" Aeson..= ("LogJobTimeout" :: Text)

330− , "contents" Aeson..= (defaultJsonJob job) ]

330+ , "contents" Aeson..= defaultJsonJob job ]

331 LogPoll ->

332 Aeson.object [ "tag" Aeson..= ("LogJobPoll" :: Text)]

333 LogWebUIRequest ->

src/OddJobs/Endpoints.hs+12−12

@@ -65,7 +65,7 @@ data Routes route = Routes

67type FinalAPI =

68− (ToServant Routes AsApi) :<|>

68+ ToServant Routes AsApi :<|>

69 "assets" :> StaticAssetRoutes

71data Env = Env

@@ -106,14 +106,14 @@ server :: forall m . (MonadIO m)

106 -> (forall a . Handler a -> m a)

107 -> ServerT FinalAPI m

108server cfg env nt =

109− (toServant routeServer) :<|> staticAssetServer

109+ toServant routeServer :<|> staticAssetServer

110 where

111 routeServer :: Routes (AsServerT m)

112 routeServer = Routes

113− { rFilterResults = nt . (filterResults cfg env)

113+ { rFilterResults = nt . filterResults cfg env

114− , rEnqueue = nt . (enqueueJob cfg env)

114+ , rEnqueue = nt . enqueueJob cfg env

115− , rCancel = nt . (cancelJob cfg env)

115+ , rCancel = nt . cancelJob cfg env

116− , rRunNow = nt . (runJobNow cfg env)

116+ , rRunNow = nt . runJobNow cfg env

117 , rRefreshJobTypes = nt $ refreshJobTypes cfg env

118 , rRefreshJobRunners = nt $ refreshJobRunners cfg env

119 }

@@ -122,10 +122,10 @@ server2 :: UIConfig

122 -> Env

123 -> Routes AsServer

124server2 cfg env = Routes

125− { rFilterResults = (filterResults cfg env)

125+ { rFilterResults = filterResults cfg env

126− , rEnqueue = (enqueueJob cfg env)

126+ , rEnqueue = enqueueJob cfg env

127− , rCancel = (cancelJob cfg env)

127+ , rCancel = cancelJob cfg env

128− , rRunNow = (runJobNow cfg env)

128+ , rRunNow = runJobNow cfg env

129 , rRefreshJobTypes = refreshJobTypes cfg env

130 , rRefreshJobRunners = refreshJobRunners cfg env

131 }

@@ -185,8 +185,8 @@ filterResults :: UIConfig

185filterResults cfg@UIConfig{uicfgJobToHtml, uicfgDbPool} Env{..} mFilter = do

186 let filters = fromMaybe mempty mFilter

187 (jobs, runningCount) <- liftIO $ Pool.withResource uicfgDbPool $ \conn -> (,)

188− <$> (filterJobs cfg conn filters)

188+ <$> filterJobs cfg conn filters

189− <*> (countJobs cfg conn filters{ filterStatuses = [Job.Locked] })

189+ <*> countJobs cfg conn filters{ filterStatuses = [Job.Locked] }

190 t <- liftIO getCurrentTime

191 js <- liftIO (DL.zip jobs <$> uicfgJobToHtml jobs)

192 allJobTypes <- readIORef envJobTypesRef

src/OddJobs/Job.hs+23−23

@@ -216,7 +216,7 @@ jobWorkerName :: IO String

216jobWorkerName = do

217 pid <- getProcessID

218 hname <- getHostName

219− pure $ hname ++ ":" ++ (show pid)

219+ pure $ hname ++ ":" ++ show pid

220

221-- | If you are writing SQL queries where you want to return ALL columns from

222-- the jobs table it is __recommended__ that you do not issue a @SELECT *@ or

@@ -288,7 +288,7 @@ findJobByIdIO :: Connection -> TableName -> JobId -> IO (Maybe Job)

288findJobByIdIO conn tname jid = PGS.query conn findJobByIdQuery (tname, jid) >>= \case

289 [] -> pure Nothing

290 [j] -> pure (Just j)

291− _js -> Prelude.error $ "Not expecting to find multiple jobs by id=" <> (show jid)

291+ _js -> Prelude.error $ "Not expecting to find multiple jobs by id=" <> show jid

292

293

294saveJobQuery :: PGS.Query

@@ -316,9 +316,9 @@ saveJobIO conn tname Job{jobRunAt, jobStatus, jobPayload, jobLastError, jobAttem

316 , jobId

317 )

318 case rs of

319− [] -> Prelude.error $ "Could not find job while updating it id=" <> (show jobId)

319+ [] -> Prelude.error $ "Could not find job while updating it id=" <> show jobId

320 [j] -> pure j

321− _js -> Prelude.error $ "Not expecting multiple rows to ber returned when updating job id=" <> (show jobId)

321+ _js -> Prelude.error $ "Not expecting multiple rows to ber returned when updating job id=" <> show jobId

322

323deleteJob :: (HasJobRunner m) => JobId -> m ()

324deleteJob jid = do

@@ -388,13 +388,13 @@ runJobWithTimeout timeoutSec job = do

388

389runJob :: (HasJobRunner m) => JobId -> m ()

390runJob jid = do

391− (findJobById jid) >>= \case

391+ findJobById jid >>= \case

392 Nothing -> Prelude.error $ "Could not find job id=" <> show jid

393 Just job -> do

394 startTime <- liftIO getCurrentTime

395 lockTimeout <- getDefaultJobTimeout

396 log LevelInfo $ LogJobStart job

397− (flip catches) [Handler $ timeoutHandler job startTime, Handler $ exceptionHandler job startTime] $ do

397+ flip catches [Handler $ timeoutHandler job startTime, Handler $ exceptionHandler job startTime] $ do

398 runJobWithTimeout lockTimeout job

399 endTime <- liftIO getCurrentTime

400 shouldDeleteJob <- deleteSuccessfulJobs

@@ -420,8 +420,8 @@ runJob jid = do

420 newJob <- saveJob job{ jobStatus=newStatus

421 , jobLockedBy=Nothing

422 , jobLockedAt=Nothing

423− , jobLastError=(Just $ toJSON $ show e) -- TODO: convert errors to json properly

423+ , jobLastError=Just $ toJSON $ show e -- TODO: convert errors to json properly

424− , jobRunAt=(addUTCTime (fromIntegral $ unSeconds backoffInSeconds) t)

424+ , jobRunAt=addUTCTime (fromIntegral $ unSeconds backoffInSeconds) t

425 }

426 case fromException e :: Maybe TimeoutException of

427 Nothing -> log logLevel $ LogJobFailed newJob e failureMode runTime

@@ -440,7 +440,7 @@ restartUponCrash name_ action = do

440 traceM "restartUponCrash top"

441 a <- async action

442 finally (waitCatch a >>= fn) $ do

443− (log LevelInfo $ LogText $ "Received shutdown: " <> toS name_)

443+ log LevelInfo $ LogText $ "Received shutdown: " <> toS name_

444 cancel a

445 where

446 fn x = do

@@ -480,7 +480,7 @@ waitForJobs = do

480 as -> do

481 tid <- myThreadId

482 void $ waitAnyCatch as

483− log LevelDebug $ LogText $ toS $ "Waiting for " <> show (DL.length as) <> " jobs to complete before shutting down. myThreadId=" <> (show tid)

483+ log LevelDebug $ LogText $ toS $ "Waiting for " <> show (DL.length as) <> " jobs to complete before shutting down. myThreadId=" <> show tid

484 delaySeconds (Seconds 1)

485 waitForJobs

486

@@ -490,7 +490,7 @@ getConcurrencyControlFn = getConcurrencyControl >>= \case

490 UnlimitedConcurrentJobs -> pure $ pure True

491 MaxConcurrentJobs maxJobs -> pure $ do

492 curJobs <- getRunnerEnv >>= (readIORef . envJobThreadsRef)

493− pure $ (DL.length curJobs) < maxJobs

493+ pure $ DL.length curJobs < maxJobs

494 DynamicConcurrency fn -> pure $ liftIO fn

495

496

@@ -504,9 +504,9 @@ jobPollingIO pollerDbConn processName tname lockTimeout = do

504 , processName

505 , tname

506 , t

507− , (In [Queued, Retry])

507+ , In [Queued, Retry]

508 , Locked

509− , (addUTCTime (fromIntegral $ negate $ unSeconds lockTimeout) t))

509+ , addUTCTime (fromIntegral $ negate $ unSeconds lockTimeout) t)

510

511-- | Executes 'jobPollingSql' every 'cfgPollingInterval' seconds to pick up jobs

512-- for execution. Uses @UPDATE@ along with @SELECT...FOR UPDATE@ to efficiently

@@ -550,7 +550,7 @@ jobPoller = do

550 void $ async $ runJob jid

551 pure noDelayAction

552

553− x -> error $ "WTF just happened? I was supposed to get only a single row, but got: " ++ (show x))

553+ x -> error $ "WTF just happened? I was supposed to get only a single row, but got: " ++ show x)

554 where

555 delayAction = delaySeconds =<< getPollingInterval

556 noDelayAction = pure ()

@@ -568,15 +568,15 @@ jobEventListener = do

568

569 let tryLockingJob jid = do

570 let q = "UPDATE ? SET status=?, locked_at=now(), locked_by=?, attempts=attempts+1 WHERE id=? AND status in ? RETURNING id"

571− (withDbConnection $ \conn -> (liftIO $ PGS.query conn q (tname, Locked, jwName, jid, In [Queued, Retry]))) >>= \case

571+ (withDbConnection $ \conn -> liftIO $ PGS.query conn q (tname, Locked, jwName, jid, In [Queued, Retry])) >>= \case

572 [] -> do

573 log LevelDebug $ LogText $ toS $ "Job was locked by someone else before I could start. Skipping it. JobId=" <> show jid

574 pure Nothing

575 [Only (_ :: JobId)] -> pure $ Just jid

576− x -> error $ "WTF just happned? Was expecting a single row to be returned, received " ++ (show x)

576+ x -> error $ "WTF just happned? Was expecting a single row to be returned, received " ++ show x

577

578 withResource pool $ \monitorDbConn -> do

579− void $ liftIO $ PGS.execute monitorDbConn ("LISTEN ?") (Only $ pgEventName tname)

579+ void $ liftIO $ PGS.execute monitorDbConn "LISTEN ?" (Only $ pgEventName tname)

580 forever $ do

581 log LevelDebug $ LogText "[LISTEN/NOTIFY] Event loop"

582 notif <- liftIO $ getNotification monitorDbConn

@@ -585,16 +585,16 @@ jobEventListener = do

585 True -> do

586 let pload = notificationData notif

587 log LevelDebug $ LogText $ toS $ "NOTIFY | " <> show pload

588− case (eitherDecode $ toS pload) of

588+ case eitherDecode $ toS pload of

589 Left e -> log LevelError $ LogText $ toS $ "Unable to decode notification payload received from Postgres. Payload=" <> show pload <> " Error=" <> show e

590

591 -- Checking if job needs to be fired immediately AND it is not already

592 -- taken by some othe thread, by the time it got to us

593− Right (v :: Value) -> case (Aeson.parseMaybe parser v) of

593+ Right (v :: Value) -> case Aeson.parseMaybe parser v of

594 Nothing -> log LevelError $ LogText $ toS $ "Unable to extract id/run_at/locked_at from " <> show pload

595 Just (jid, runAt_, mLockedAt_) -> do

596 t <- liftIO getCurrentTime

597− if (runAt_ <= t) && (isNothing mLockedAt_)

597+ if (runAt_ <= t) && isNothing mLockedAt_

598 then do log LevelDebug $ LogText $ toS $ "Job needs needs to be run immediately. Attempting to fork in background. JobId=" <> show jid

599 void $ async $ do

600 -- Let's try to lock the job first... it is possible that it has already

@@ -654,12 +654,12 @@ scheduleJob :: ToJSON p

654 -> IO Job

655scheduleJob conn tname payload runAt = do

656 let args = ( tname, runAt, Queued, toJSON payload, Nothing :: Maybe Value, 0 :: Int, Nothing :: Maybe Text, Nothing :: Maybe Text )

657− queryFormatter = toS <$> (PGS.formatQuery conn createJobQuery args)

657+ queryFormatter = toS <$> PGS.formatQuery conn createJobQuery args

658 rs <- PGS.query conn createJobQuery args

659 case rs of

660− [] -> (Prelude.error . (<> "Not expecting a blank result set when creating a job. Query=")) <$> queryFormatter

660+ [] -> Prelude.error . (<> "Not expecting a blank result set when creating a job. Query=") <$> queryFormatter

661 [r] -> pure r

662− _ -> (Prelude.error . (<> "Not expecting multiple rows when creating a single job. Query=")) <$> queryFormatter

662+ _ -> Prelude.error . (<> "Not expecting multiple rows when creating a single job. Query=") <$> queryFormatter

663

664

665-- getRunnerEnv :: (HasJobRunner m) => m RunnerEnv

src/OddJobs/Migrations.hs+2−2

@@ -69,6 +69,6 @@ createJobTable conn tname = void $ do

69 , fnName

70 )

71 where

72− fnName = PGS.Identifier $ "notify_job_monitor_for_" <> (getTnameTxt tname)

72+ fnName = PGS.Identifier $ "notify_job_monitor_for_" <> getTnameTxt tname

73− trgName = PGS.Identifier $ "trg_notify_job_monitor_for_" <> (getTnameTxt tname)

73+ trgName = PGS.Identifier $ "trg_notify_job_monitor_for_" <> getTnameTxt tname

74 getTnameTxt (PGS.QualifiedIdentifier _ tname') = tname'

src/OddJobs/Web.hs+19−19

@@ -181,8 +181,8 @@ filterJobsQuery UIConfig{uicfgTableName, uicfgJobTypeSql} Filter{..} =

181 let qFragment = "(" <> uicfgJobTypeSql <> ")=?"

182 build ys (q, vs) = case ys of

183 [] -> (q, vs)

184− [y] -> (qFragment <> q, (toField y):vs)

184+ [y] -> (qFragment <> q, toField y : vs)

185− (y:ys_) -> build ys_ (" OR " <> qFragment <> q, (toField y):vs)

185+ (y:ys_) -> build ys_ (" OR " <> qFragment <> q, toField y : vs)

186 in Just $ build xs (mempty, [])

187

188 jobRunnerClause :: Maybe (Query, [Action])

@@ -275,13 +275,13 @@ sideNav Routes{..} jobTypes jobRunnerNames _t filter@Filter{..} = do

275 div_ [ class_ "card" ] $ do

276 ul_ [ class_ "list-group list-group-flush" ] $ do

277 li_ [ class_ ("list-group-item " <> if filterStatuses == [] then "active-nav" else "") ] $ do

278− let lnk = (rFilterResults $ Just filter{filterStatuses = [], filterPage = (OddJobs.Web.filterPage blankFilter)})

278+ let lnk = rFilterResults $ Just filter{filterStatuses = [], filterPage = OddJobs.Web.filterPage blankFilter}

279 a_ [ href_ lnk ] $ do

280 "all"

281 -- span_ [ class_ "badge badge-pill badge-secondary float-right" ] "12"

282 forM_ ((\\) (enumFrom minBound) [Job.Success]) $ \st -> do

283− li_ [ class_ ("list-group-item " <> if (st `elem` filterStatuses) then "active-nav" else "") ] $ do

283+ li_ [ class_ ("list-group-item " <> if st `elem` filterStatuses then "active-nav" else "") ] $ do

284− let lnk = (rFilterResults $ Just filter{filterStatuses = [st], filterPage = Nothing})

284+ let lnk = rFilterResults $ Just filter{filterStatuses = [st], filterPage = Nothing}

285 a_ [ href_ lnk ] $ do

286 toHtml $ toText st

287 -- span_ [ class_ "badge badge-pill badge-secondary float-right" ] "12"

@@ -296,10 +296,10 @@ sideNav Routes{..} jobTypes jobRunnerNames _t filter@Filter{..} = do

296 div_ [ class_ "card" ] $ do

297 ul_ [ class_ "list-group list-group-flush" ] $ do

298 li_ [ class_ ("list-group-item " <> if filterJobRunner == [] then "active-nav" else "") ] $ do

299− let lnk = (rFilterResults $ Just filter{filterJobRunner = [], filterPage = (OddJobs.Web.filterPage blankFilter)})

299+ let lnk = rFilterResults $ Just filter{filterJobRunner = [], filterPage = OddJobs.Web.filterPage blankFilter}

300 a_ [ href_ lnk ] "all"

301 forM_ jobRunnerNames $ \jr -> do

302− li_ [ class_ ("list-group-item" <> if (jr `elem` filterJobRunner) then " active-nav" else "")] $ do

302+ li_ [ class_ ("list-group-item" <> if jr `elem` filterJobRunner then " active-nav" else "")] $ do

303 a_ [ href_ "#" ] $ toHtml $ unJobRunnerName jr

304

305 jobTypeFilters = do

@@ -312,10 +312,10 @@ sideNav Routes{..} jobTypes jobRunnerNames _t filter@Filter{..} = do

312 div_ [ class_ "card" ] $ do

313 ul_ [ class_ "list-group list-group-flush" ] $ do

314 li_ [ class_ ("list-group-item " <> if filterJobTypes == [] then "active-nav" else "") ] $ do

315− let lnk = (rFilterResults $ Just filter{filterJobTypes = [], filterPage = (OddJobs.Web.filterPage blankFilter)})

315+ let lnk = rFilterResults $ Just filter{filterJobTypes = [], filterPage = OddJobs.Web.filterPage blankFilter}

316 a_ [ href_ lnk ] "all"

317 forM_ jobTypes $ \jt -> do

318− li_ [ class_ ("list-group-item" <> if (jt `elem` filterJobTypes) then " active-nav" else "")] $ do

318+ li_ [ class_ ("list-group-item" <> if jt `elem` filterJobTypes then " active-nav" else "")] $ do

319 a_ [ href_ (rFilterResults $ Just filter{filterJobTypes=[jt]}) ] $ toHtml jt

320

321searchBar :: Routes -> UTCTime -> Filter -> Html ()

@@ -359,10 +359,10 @@ timeDuration from to = (diff, str)

359 where

360 str = if diff <= 0

361 then "under 1s"

362− else (if d>0 then (show d) <> "d" else "") <>

362+ else (if d>0 then show d <> "d" else "") <>

363− (if m>0 then (show m) <> "m" else "") <>

363+ (if m>0 then show m <> "m" else "") <>

364− (if s>0 then (show s) <> "s" else "")

364+ (if s>0 then show s <> "s" else "")

365− diff = (abs $ round $ diffUTCTime from to)

365+ diff = abs $ round $ diffUTCTime from to

366 (m', s) = diff `divMod` 60

367 (h', m) = m' `divMod` 60

368 (d, _h) = h' `divMod` 24

@@ -392,13 +392,13 @@ jobRow routes t (job@Job{..}, jobHtml) = do

392 td_ jobHtml

393 td_ $ do

394 let actionsFn = case jobStatus of

395− Job.Success -> (const mempty)

395+ Job.Success -> const mempty

396 Job.Failed -> actionsFailed

397 Job.Queued -> if jobRunAt > t

398 then actionsFuture

399 else actionsWaiting

400 Job.Retry -> actionsRetry

401− Job.Locked -> (const mempty)

401+ Job.Locked -> const mempty

402 actionsFn routes job

403

404

@@ -492,13 +492,13 @@ resultsPanel routes@Routes{..} t filter@Filter{filterPage} js runningCount = do

492 nextLink = do

493 let (extraClass, lnk) = case filterPage of

494 Nothing ->

495− if (DL.length js) < 10

495+ if DL.length js < 10

496 then ("disabled", "")

497− else ("", (rFilterResults $ Just $ filter {filterPage = Just (10, 10)}))

497+ else ("", rFilterResults $ Just $ filter {filterPage = Just (10, 10)})

498 Just (l, o) ->

499− if (DL.length js) < l

499+ if DL.length js < l

500 then ("disabled", "")

501− else ("", (rFilterResults $ Just $ filter {filterPage = Just (l, o + l)}))

501+ else ("", rFilterResults $ Just $ filter {filterPage = Just (l, o + l)})

502 li_ [ class_ ("page-item next " <> extraClass) ] $ do

503 a_ [ class_ "page-link", href_ lnk ] "Next"

504

test/Test.hs+35−35

@@ -65,24 +65,24 @@ main = do

65#if MIN_VERSION_resource_pool(0,3,0)

66 createAppPool = Pool.newPool $ Pool.PoolConfig

67 (PGS.connect connInfo) -- create a new resource

68− (PGS.close) -- destroy resource

68+ PGS.close -- destroy resource

69 (fromRational 10) -- number of seconds unused resources are kept around

70 45

71 createJobPool = Pool.newPool $ Pool.PoolConfig

72 (PGS.connect connInfo) -- create a new resource

73− (PGS.close) -- destroy resource

73+ PGS.close -- destroy resource

74 (fromRational 10) -- number of seconds unused resources are kept around

75 45

76#else

77 createAppPool = Pool.createPool

78 (PGS.connect connInfo) -- create a new resource

79− (PGS.close) -- destroy resource

79+ PGS.close -- destroy resource

80 1 -- stripes

81 (fromRational 10) -- number of seconds unused resources are kept around

82 45

83 createJobPool = Pool.createPool

84 (PGS.connect connInfo) -- create a new resource

85− (PGS.close) -- destroy resource

85+ PGS.close -- destroy resource

86 1 -- stripes

87 (fromRational 10) -- number of seconds unused resources are kept around

88 45

@@ -139,15 +139,15 @@ testPayload :: Value

139testPayload = toJSON (10 :: Int)

140

141jobRunner :: Job.Job -> IO ()

142−jobRunner Job{jobPayload, jobAttempts} = case (fromJSON jobPayload) of

142+jobRunner Job{jobPayload, jobAttempts} = case fromJSON jobPayload of

143 Aeson.Error e -> error e

144 Success (j :: JobPayload) ->

145 let recur pload idx = case pload of

146− PayloadAlwaysFail delay -> (delaySeconds delay) >> (error $ "Forced error after " <> show delay <> " seconds")

146+ PayloadAlwaysFail delay -> delaySeconds delay >> (error $ "Forced error after " <> show delay <> " seconds")

147 PayloadSucceed delay -> void $ delaySeconds delay

148 PayloadFail delay innerpload -> if idx<jobAttempts

149 then recur innerpload (idx + 1)

150− else (delaySeconds delay) >> (error $ "Forced error after " <> show delay <> " seconds. step=" <> show idx)

150+ else delaySeconds delay >> (error $ "Forced error after " <> show delay <> " seconds. step=" <> show idx)

151 PayloadThrowStringException s -> throwString s

152 PayloadThrowDivideByZero -> seq (1 `div` 0 :: Integer) (pure ())

153 in recur j 0

@@ -176,7 +176,7 @@ logEventToJob le = case le of

176 Job.LogWebUIRequest -> Nothing

177 Job.LogText _ -> Nothing

178

179−assertJobIdStatus :: (HasCallStack)

179+assertJobIdStatus :: HasCallStack

180 => Connection

181 -> Job.TableName

182 -> IORef [Job.LogEvent]

@@ -190,13 +190,13 @@ assertJobIdStatus conn tname logRef msg st jid = do

190 case st of

191 Job.Success ->

192 assertBool (msg <> ": Success event not found in job-logs for JobId=" <> show jid) $

193− (flip DL.any) logs $ \case

193+ flip DL.any logs $ \case

194 Job.LogJobSuccess j _ -> jid == Job.jobId j

195 _ -> False

196

197 Job.Queued ->

198 assertBool (msg <> ": Not expecting to find a queued job in the the job-logs JobId=" <> show jid) $

199− not $ (flip DL.any) logs $ \case

199+ not $ flip DL.any logs $ \case

200 Job.LogJobStart j -> jid == Job.jobId j

201 Job.LogJobSuccess j _ -> jid == Job.jobId j

202 Job.LogJobFailed j _ _ _ -> jid == Job.jobId j

@@ -207,19 +207,19 @@ assertJobIdStatus conn tname logRef msg st jid = do

207

208 Job.Failed ->

209 assertBool (msg <> ": Failed event not found in job-logs for JobId=" <> show jid) $

210− (flip DL.any) logs $ \case

210+ flip DL.any logs $ \case

211 Job.LogJobFailed j _ _ _ -> jid == Job.jobId j

212 _ -> False

213

214 Job.Retry ->

215 assertBool (msg <> ": Failed event not found in job-logs for JobId=" <> show jid) $

216− (flip DL.any) logs $ \case

216+ flip DL.any logs $ \case

217 Job.LogJobFailed j _ _ _ -> jid == Job.jobId j

218 _ -> False

219

220 Job.Locked ->

221 assertBool (msg <> ": Start event should be present in the log for a locked job JobId=" <> show jid) $

222− (flip DL.any) logs $ \case

222+ flip DL.any logs $ \case

223 Job.LogJobStart j -> jid == Job.jobId j

224 _ -> False

225

@@ -228,16 +228,16 @@ assertJobIdStatus conn tname logRef msg st jid = do

228 Nothing -> assertFailure $ "Not expecting job to be deleted. JobId=" <> show jid

229 Just (Job{jobStatus}) -> assertEqual msg st jobStatus

230

231−ensureJobId :: (HasCallStack) => Connection -> Job.TableName -> JobId -> IO Job

231+ensureJobId :: HasCallStack => Connection -> Job.TableName -> JobId -> IO Job

232ensureJobId conn tname jid = Job.findJobByIdIO conn tname jid >>= \case

233 Nothing -> error $ "Not expecting job to be deleted. JobId=" <> show jid

234 Just j -> pure j

235

236-- withRandomTable :: (MonadIO m) => Pool Connection -> (Job.TableName -> m a) -> m a

237withRandomTable jobPool action = do

238− (tname :: Job.TableName) <- liftIO ((fromString . ("jobs_" <>)) <$> (replicateM 10 (R.randomRIO ('a', 'z'))))

238+ (tname :: Job.TableName) <- liftIO (fromString . ("jobs_" <>) <$> replicateM 10 (R.randomRIO ('a', 'z')))

239 finally

240− ((Pool.withResource jobPool $ \conn -> (liftIO $ Migrations.createJobTable conn tname)) >> (action tname))

240+ ((Pool.withResource jobPool $ \conn -> liftIO $ Migrations.createJobTable conn tname) >> action tname)

241 (Pool.withResource jobPool $ \conn -> liftIO $ void $ PGS.execute conn "drop table if exists ?" (Only tname))

242

243testMaxAttempts :: Int

@@ -253,7 +253,7 @@ withNamedJobMonitor tname jobPool cfgFn actualTest = do

253 tcache <- newTimeCache simpleTimeFormat'

254 withTimedFastLogger tcache LogNone $ \tlogger -> do

255 let flogger logLevel logEvent = do

256− tlogger $ \t -> toLogStr t <> " | " <> (Job.defaultLogStr Job.defaultJobType logLevel logEvent)

256+ tlogger $ \t -> toLogStr t <> " | " <> Job.defaultLogStr Job.defaultJobType logLevel logEvent

257 atomicModifyIORef' logRef (\logs -> (logEvent:logs, ()))

258 cfg = Job.mkConfig flogger tname jobPool Job.UnlimitedConcurrentJobs jobRunner (\cfg' -> cfgFn $ cfg'{Job.cfgDefaultMaxAttempts=testMaxAttempts})

259 withAsync (Job.startJobRunner cfg) (const $ actualTest logRef)

@@ -263,7 +263,7 @@ payloadGen = Gen.recursive Gen.choice nonRecursive recursive

263 where

264 nonRecursive = [ PayloadAlwaysFail <$> Gen.element [1, 2, 3]

265 , PayloadSucceed <$> Gen.element [1, 2, 3]]

266− recursive = [ PayloadFail <$> (Gen.element [1, 2, 3]) <*> payloadGen ]

266+ recursive = [ PayloadFail <$> Gen.element [1, 2, 3] <*> payloadGen ]

267

268testJobCreation appPool jobPool = testCase "job creation" $ do

269 withNewJobMonitor jobPool $ \tname logRef -> do

@@ -282,7 +282,7 @@ testEnsureShutdown appPool jobPool = testCase "ensure shutdown" $ do

282 scheduleJob tname = withNamedJobMonitor tname jobPool Prelude.id $ \logRef -> do

283 t <- getCurrentTime

284 Pool.withResource appPool $ \conn -> do

285− Job{jobId} <- Job.scheduleJob conn tname (PayloadSucceed 0) (addUTCTime (fromIntegral (2 * (unSeconds Job.defaultPollingInterval))) t)

285+ Job{jobId} <- Job.scheduleJob conn tname (PayloadSucceed 0) (addUTCTime (fromIntegral (2 * unSeconds Job.defaultPollingInterval)) t)

286 assertJobIdStatus conn tname logRef "Job is scheduled in future, should still be queueud" Job.Queued jobId

287 pure (jobId, logRef)

288

@@ -331,15 +331,15 @@ testJobScheduling appPool jobPool = testCase "job scheduling" $ do

331 job@Job{jobId} <- Job.scheduleJob conn tname (PayloadSucceed 0) (addUTCTime (fromIntegral (3600 :: Integer)) t)

332 delaySeconds $ Seconds 2

333 assertJobIdStatus conn tname logRef "Job is scheduled in the future. It should NOT have been successful by now" Job.Queued jobId

334− _ <- Job.saveJobIO conn tname job{jobRunAt = (addUTCTime (fromIntegral (-1 :: Integer)) t)}

334+ _ <- Job.saveJobIO conn tname job{jobRunAt = addUTCTime (fromIntegral (-1 :: Integer)) t}

335− delaySeconds (Job.defaultPollingInterval + (Seconds 2))

335+ delaySeconds (Job.defaultPollingInterval + Seconds 2)

336 assertJobIdStatus conn tname logRef "Job had a runAt date in the past. It should have been successful by now" Job.Success jobId

337

338testJobFailure appPool jobPool = testCase "job failure" $ do

339 withNewJobMonitor jobPool $ \tname _logRef -> do

340 Pool.withResource appPool $ \conn -> do

341 Job{jobId} <- Job.createJob conn tname (PayloadAlwaysFail 0)

342− delaySeconds $ (calculateRetryDelay testMaxAttempts) + (Seconds 3)

342+ delaySeconds $ calculateRetryDelay testMaxAttempts + Seconds 3

343 Job{jobAttempts, jobStatus} <- ensureJobId conn tname jobId

344 assertEqual "Exepcting job to be in Failed status" Job.Failed jobStatus

345 assertEqual ("Expecting job attempts to be 3. Found " <> show jobAttempts) 3 jobAttempts

@@ -531,7 +531,7 @@ timeGen t d = do

531 pure $ Time.timeSince t (fromInteger i) u d

532

533anyTimeGen :: MonadGen m => UTCTime -> m UTCTime

534−anyTimeGen t = (Gen.element (enumFrom Time.Ago)) >>= (timeGen t)

534+anyTimeGen t = Gen.element (enumFrom Time.Ago) >>= timeGen t

535

536futureTimeGen :: MonadGen m => UTCTime -> m UTCTime

537futureTimeGen t = timeGen t Time.FromThat

@@ -584,7 +584,7 @@ genFilter t = do

584 Nothing -> Gen.maybe (anyTimeGen t)

585 Just x -> Gen.maybe (futureTimeGen x)

586 orderClause <- Gen.maybe ((,) <$> (Gen.element $ enumFrom Web.OrdCreatedAt) <*> (Gen.element $ enumFrom Web.Asc))

587− limitOffset <- Gen.maybe ((,) <$> (Gen.int (Range.constant 5 10)) <*> (Gen.int (Range.constant 0 30)))

587+ limitOffset <- Gen.maybe ((,) <$> Gen.int (Range.constant 5 10) <*> Gen.int (Range.constant 0 30))

588 runAfter <- Gen.maybe (futureTimeGen t)

589 pure Web.blankFilter

590 { filterStatuses = statuses

@@ -602,21 +602,21 @@ filterJobs :: Filter -> [Job] -> [Job]

602filterJobs Web.Filter{filterStatuses, filterCreatedAfter, filterCreatedBefore, filterUpdatedAfter, filterUpdatedBefore, filterOrder, filterPage, filterRunAfter} js =

603 applyLimitOffset $

604 applyOrdering (fromMaybe (Web.OrdUpdatedAt, Web.Desc) filterOrder) $

605− (flip DL.filter) js $ \j -> (filterByStatus j) &&

605+ flip DL.filter js $ \j -> filterByStatus j &&

606− (filterByCreatedAfter j) &&

606+ filterByCreatedAfter j &&

607− (filterByCreatedBefore j) &&

607+ filterByCreatedBefore j &&

608− (filterByUpdatedAfter j) &&

608+ filterByUpdatedAfter j &&

609− (filterByUpdatedBefore j) &&

609+ filterByUpdatedBefore j &&

610− (filterByRunAfter j)

610+ filterByRunAfter j

611 where

612− applyLimitOffset = maybe Prelude.id (\(l, o) -> (Prelude.take l). (Prelude.drop o)) filterPage

612+ applyLimitOffset = maybe Prelude.id (\(l, o) -> Prelude.take l . Prelude.drop o) filterPage

613

614 applyOrdering (fld, dir) lst =

615 let comparer = resultOrder $ case fld of

616− Web.OrdCreatedAt -> (comparing jobCreatedAt)

616+ Web.OrdCreatedAt -> comparing jobCreatedAt

617− Web.OrdUpdatedAt -> (comparing jobUpdatedAt)

617+ Web.OrdUpdatedAt -> comparing jobUpdatedAt

618− Web.OrdLockedAt -> (comparing jobLockedAt)

618+ Web.OrdLockedAt -> comparing jobLockedAt

619− Web.OrdStatus -> (comparing jobStatus)

619+ Web.OrdStatus -> comparing jobStatus

620 Web.OrdJobType -> comparing Job.defaultJobType

621 resultOrder fn x y = case fn x y of

622 EQ -> compare (Down $ jobId x) (Down $ jobId y)