8458b85 · odd-jobs · git.iko.soy

git.iko.soy/odd-jobs

Extract UI related config params into a UIConfig type (#76)

* Lot of changes to allow running the web UI separately from the from job-runner - Separated Config and UIConfig - Allowing the Cli to run only the job-runnner, only the web-ui, or both * cleanup and docs

commit8458b8584fe9c64502b4a41a124b5d7bbd35abce authorSaurabh Nanda <saurabh@vacationlabs.com> dateWed 11 Aug 2021, 22:33 (5 years ago) parentab15d8b

11 files changed+272−206

compare with master

unifiedsplit

examples/OddJobsCliExample.lhs+18−25 odd-jobs.cabal+5−5 package.yaml+1−1 src/OddJobs/Cli.hs+105−97 src/OddJobs/ConfigBuilder.hs+57−25 src/OddJobs/Endpoints.hs+22−22 src/OddJobs/Job.hs+14−15 src/OddJobs/Migrations.hs+3 src/OddJobs/Types.hs+39−9 src/OddJobs/Web.hs+6−6 stack.yaml+2−1

examples/OddJobsCliExample.lhs+18−25

@@ -21,18 +21,20 @@ Ideally, this module should be compiled into a separate executable and should de

2121{-# LANGUAGE NamedFieldPuns #-}

2222{-# LANGUAGE OverloadedStrings #-}

2323{-# LANGUAGE LambdaCase #-}

24+{-# LANGUAGE RecordWildCards #-}

2425

2526module OddJobsCliExample where

2627

27−import OddJobs.Job (Job(..), ConcurrencyControl(..), Config(..), throwParsePayload)

28−import OddJobs.ConfigBuilder (mkConfig, withConnectionPool, defaultTimedLogger, defaultLogStr, defaultJobType)

29−import OddJobs.Cli (defaultMain)

28+import OddJobs.Job (Job(..), ConcurrencyControl(..), Config(..), throwParsePayload, startJobRunner, LogLevel(..), LogEvent(..))

29+import OddJobs.ConfigBuilder (mkConfig, withConnectionPool, defaultTimedLogger, defaultLogStr, defaultJobType, mkUIConfig)

30+import OddJobs.Cli (runCli, defaultWebUI, CliType(..))

3031

3132-- Note: It is not necessary to use fast-logger. You can use any logging library

3233-- that can give you a logging function in the IO monad.

33−import System.Log.FastLogger(withTimedFastLogger, LogType'(..), defaultBufSize)

34+import System.Log.FastLogger(withTimedFastLogger, LogType'(..), defaultBufSize, newTimedFastLogger)

3435import System.Log.FastLogger.Date (newTimeCache, simpleTimeFormat)

35−

36+import Database.PostgreSQL.Simple as PGS

37+import Data.Pool

3638import Data.Text (Text)

3739import Data.Aeson as Aeson

3840import GHC.Generics

@@ -87,32 +89,23 @@ myJobRunner job = do

8789

8890\begin{code}

8991main :: IO ()

90−main = do

91− defaultMain startJobMonitor

92+main = runCli CliBoth{..}

9293 where

93− -- A callback-within-callback function. If the commands-line args contain a

94− -- `start` command, this function will be called. Once this function has

95− -- constructed the 'Config' (which requires setting up a logging function,

96− -- and a DB pool) it needs to execute the `callback` function that is passed

97− -- to it.

98− startJobMonitor callback =

99−

100− -- a utility function provided by `OddJobs.ConfigBuilder` which ensures

101− -- that the DB pool is gracefully destroyed upon shutdown.

94+ cliStartJobRunner cfgOverrideFn = do

10295 withConnectionPool (Left "dbname=jobs_test user=jobs_test password=jobs_test host=localhost")$ \dbPool -> do

103−

104− -- Boilerplate code to setup a TimedFastLogger (from the fast-logger library)

10596 tcache <- newTimeCache simpleTimeFormat

10697 withTimedFastLogger tcache (LogFileNoRotate "oddjobs.log" defaultBufSize) $ \logger -> do

107−

108− -- Using the default string-based logging provided by

109− -- `OddJobs.ConfigBuilder`. If you want to actually use

110− -- structured-logging you'll need to define your own logging function.

11198 let jobLogger = defaultTimedLogger logger (defaultLogStr defaultJobType)

112− cfg = mkConfig jobLogger "jobs" dbPool (MaxConcurrentJobs 50) myJobRunner Prelude.id

99+ startJobRunner $

100+ mkConfig jobLogger "jobs" dbPool (MaxConcurrentJobs 50) myJobRunner cfgOverrideFn

113101

114− -- Finally, executing the callback function that was passed to me...

115− callback cfg

102+ cliStartWebUI uiStartArgs cfgOverrideFn = do

103+ withConnectionPool (Left "dbname=jobs_test user=jobs_test password=jobs_test host=localhost")$ \dbPool -> do

104+ tcache <- newTimeCache simpleTimeFormat

105+ withTimedFastLogger tcache (LogFileNoRotate "oddjobs-web.log" defaultBufSize) $ \logger -> do

106+ let jobLogger = defaultTimedLogger logger (defaultLogStr defaultJobType)

107+ defaultWebUI uiStartArgs $

108+ mkUIConfig jobLogger "jobs" dbPool cfgOverrideFn

116109\end{code}

117110

118111=== 6. Compile and start the Odd Jobs runner

odd-jobs.cabal+5−5

@@ -4,7 +4,7 @@ cabal-version: 1.12

44--

55-- see: https://github.com/sol/hpack

66--

7−-- hash: 6677b61240c930d793f07c90cd9dc719586179d99bdc7dc7b3dbe9a32d9a2afa

7+-- hash: 81dabf5fa65d737ec98a4f07762968283cccc36292941ff7fff10a9a398e84b0

99name: odd-jobs

1010version: 0.2.2

@@ -67,7 +67,7 @@ library

6767 aeson

6868 , base >=4.7 && <5

6969 , bytestring

70− , direct-daemonize

70+ , daemons

7171 , directory

7272 , either

7373 , fast-logger

@@ -121,7 +121,7 @@ executable devel

121121 aeson

122122 , base >=4.7 && <5

123123 , bytestring

124− , direct-daemonize

124+ , daemons

125125 , directory

126126 , either

127127 , fast-logger

@@ -168,7 +168,7 @@ executable odd-jobs-cli-example

168168 aeson

169169 , base >=4.7 && <5

170170 , bytestring

171− , direct-daemonize

171+ , daemons

172172 , directory

173173 , either

174174 , fast-logger

@@ -226,7 +226,7 @@ test-suite jobrunner

226226 , base >=4.7 && <5

227227 , bytestring

228228 , containers

229− , direct-daemonize

229+ , daemons

230230 , directory

231231 , either

232232 , fast-logger

package.yaml+1−1

@@ -85,7 +85,7 @@ dependencies:

8585 - warp

8686 - unordered-containers

8787 - optparse-applicative

88− - direct-daemonize

88+ - daemons

8989 - filepath

9090 - directory

9191 - generic-deriving

src/OddJobs/Cli.hs+105−97

@@ -7,7 +7,10 @@ module OddJobs.Cli where

77import Options.Applicative as Opts

88import Data.Text

99import OddJobs.Job (startJobRunner, Config(..))

10−import System.Daemonize (DaemonOptions(..), daemonize)

10+import OddJobs.Types (UIConfig(..))

11+import OddJobs.Job(LogLevel(..), LogEvent(..))

12+-- import System.Daemonize (DaemonOptions(..), daemonize)

13+import qualified System.Posix.Daemon as Daemon

1114import System.FilePath (FilePath)

1215import System.Posix.Process (getProcessID)

1316import qualified System.Directory as Dir

@@ -16,6 +19,8 @@ import System.Environment (getProgName)

1619import OddJobs.Types (Seconds(..), delaySeconds)

1720import qualified System.Posix.Signals as Sig

1821import qualified UnliftIO.Async as Async

22+import UnliftIO (bracket_)

23+import Safe (fromJustNote)

1924import qualified OddJobs.Endpoints as UI

2025import Servant.Server as Servant

2126import Servant.API

@@ -23,6 +28,7 @@ import Data.Proxy

2328import Data.Text.Encoding (decodeUtf8)

2429import Network.Wai.Handler.Warp as Warp

2530import Debug.Trace

31+import Data.String.Conv (toS)

2632

2733-- * Introduction

2834--

@@ -57,6 +63,11 @@ import Debug.Trace

5763-- #defaultBehaviour#

5864--

5965

66+

67+data CliType = CliOnlyJobRunner { cliStartJobRunner :: (Config -> Config) -> IO () }

68+ | CliOnlyWebUi { cliStartWebUI :: UIStartArgs -> (UIConfig -> UIConfig) -> IO () }

69+ | CliBoth { cliStartJobRunner :: (Config -> Config) -> IO (), cliStartWebUI :: UIStartArgs -> (UIConfig -> UIConfig) -> IO () }

70+

6071{-|

6172Please do not get scared by the type-signature of the first argument.

6273Conceptually, it's a callback, within another callback.

@@ -81,15 +92,12 @@ Please take a look at the [getting started

8192guide](https://www.haskelltutorials.com/odd-jobs/guide.html#getting-started) for

8293an example of how to use this function.

8394-}

84−defaultMain :: ((Config -> IO ()) -> IO ())

85− -- ^ A callback function that will be executed once the dameon has

86− -- forked into the background.

87− -> IO ()

88−defaultMain startFn = do

89− Args{argsCommand} <- customExecParser defaultCliParserPrefs defaultCliInfo

95+runCli :: CliType -> IO ()

96+runCli cliType = do

97+ Args{argsCommand} <- customExecParser defaultCliParserPrefs (defaultCliInfo cliType)

9098 case argsCommand of

91− Start cmdArgs -> do

92− defaultStartCommand cmdArgs startFn

99+ Start commonArgs mUIArgs ->

100+ defaultStartCommand commonArgs mUIArgs cliType

93101 Stop cmdArgs -> do

94102 defaultStopCommand cmdArgs

95103 Status ->

@@ -104,54 +112,50 @@ defaultMain startFn = do

104112* If it exists, it refuses to start, to prevent multiple invocations of the same

105113 background daemon.

106114-}

107−defaultStartCommand :: StartArgs

108− -> ((Config -> IO ()) -> IO ())

109− -- ^ the same callback-within-callback function described in

110− -- 'defaultMain'

115+defaultStartCommand :: CommonStartArgs

116+ -> Maybe UIStartArgs

117+ -> CliType

111118 -> IO ()

112−defaultStartCommand args@StartArgs{..} startFn = do

113− progName <- getProgName

119+defaultStartCommand CommonStartArgs{..} mUIArgs cliType = do

114120 case startDaemonize of

115− False -> do

116− startFn coreStartupFn

121+ False ->

122+ coreStartupFn

117123 True -> do

118− (Dir.doesPathExist startPidFile) >>= \case

119− True -> do

120− putStrLn $

121− "PID file already exists. Please check if " <> progName <> " is still running in the background." <>

122− " If not, you can safely delete this file and start " <> progName <> " again: " <> startPidFile

123− Exit.exitWith (Exit.ExitFailure 1)

124− False -> do

125− daemonize defaultDaemonOptions (pure ()) $ const $ do

126− pid <- getProcessID

127− writeFile startPidFile (show pid)

128− putStrLn $ "Started " <> progName <> " in background with PID=" <> show pid <> ". PID written to " <> startPidFile

129− startFn $ \cfg -> coreStartupFn cfg{cfgPidFile = Just startPidFile}

124+ Daemon.runDetached (Just startPidFile) (Daemon.ToFile "/tmp/oddjobs.out") coreStartupFn

130125 where

131− coreStartupFn cfg = do

132− Async.withAsync (defaultWebUi args cfg) $ \_ -> do

133− startJobRunner cfg

134−

135−

136−defaultWebUi :: StartArgs

137− -> Config

126+ uiArgs = fromJustNote "Please specify Web UI Startup Args" $ traceShowId mUIArgs

127+ coreStartupFn =

128+ case cliType of

129+ CliOnlyJobRunner{..} -> do

130+ cliStartJobRunner Prelude.id

131+ CliOnlyWebUi{..} -> do

132+ traceM "CliOnlyWebUi before"

133+ cliStartWebUI uiArgs Prelude.id

134+ CliBoth{..} -> do

135+ traceM "CliBoth before"

136+ Async.withAsync (cliStartWebUI uiArgs Prelude.id) $ \_ -> do

137+ traceM "CliBoth inside withAsync"

138+ cliStartJobRunner Prelude.id

139+ traceM "CliBoth end"

140+

141+defaultWebUI :: UIStartArgs

142+ -> UIConfig

138143 -> IO ()

139−defaultWebUi StartArgs{..} cfg@Config{..} = do

140− env <- UI.mkEnv cfg ("/" <>)

141− case startWebUiAuth of

142− Nothing -> pure ()

143− Just AuthNone ->

144− let app = UI.server cfg env Prelude.id

145− in Warp.run startWebUiPort $

146− Servant.serve (Proxy :: Proxy UI.FinalAPI) app

147− Just (AuthBasic u p) ->

144+defaultWebUI UIStartArgs{..} uicfg@UIConfig{..} = do

145+ env <- UI.mkEnv uicfg ("/" <>)

146+ case uistartAuth of

147+ AuthNone -> do

148+ let app = UI.server uicfg env Prelude.id

149+ uicfgLogger LevelInfo $ LogText $ "Starting admin UI on port " <> (toS $ show uistartPort)

150+ Warp.run uistartPort $ Servant.serve (Proxy :: Proxy UI.FinalAPI) app

151+ (AuthBasic u p) -> do

148152 let api = Proxy :: Proxy (BasicAuth "OddJobs Admin UI" OddJobsUser :> UI.FinalAPI)

149153 ctx = defaultBasicAuth (u, p) :. EmptyContext

150154 -- Now the app will receive an extra argument for OddJobsUser,

151155 -- which we aren't really interested in.

152− app _ = UI.server cfg env Prelude.id

153− in Warp.run startWebUiPort $

154− Servant.serveWithContext api ctx app

156+ app _ = UI.server uicfg env Prelude.id

157+ uicfgLogger LevelInfo $ LogText $ "Starting admin UI on port " <> (toS $ show uistartPort)

158+ Warp.run uistartPort $ Servant.serveWithContext api ctx app

155159

156160{-| Used by 'defaultMain' if 'Stop' command is issued via the CLI. Sends a

157161@SIGINT@ signal to the process indicated by 'shutPidFile'. Waits for a maximum

@@ -162,26 +166,22 @@ defaultStopCommand :: StopArgs

162166 -> IO ()

163167defaultStopCommand StopArgs{..} = do

164168 progName <- getProgName

165− pid <- read <$> (readFile shutPidFile)

169+ -- pid <- read <$> (readFile shutPidFile)

166170 if (shutTimeout == Seconds 0)

167− then forceKill pid

168− else do putStrLn $ "Sending SIGINT to pid=" <> show pid <>

171+ then Daemon.brutalKill shutPidFile

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

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

170− Sig.signalProcess Sig.sigINT pid

174+ readFile shutPidFile >>= (pure . read) >>= Sig.signalProcess Sig.sigINT

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

172176 Right _ -> do

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

174178 Exit.exitSuccess

175179 Left _ -> do

176− putStrLn $ progName <> " has still not exited."

177− forceKill pid

180+ putStrLn $ progName <> " has still not exited. Sending sigKILL for forced exit."

181+ Daemon.brutalKill shutPidFile

178182 where

179− forceKill pid = do

180− putStrLn $ "Sending SIGKILL to pid=" <> show pid

181− Sig.signalProcess Sig.sigKILL pid

182−

183183 checkProcessStatus = do

184− Dir.doesPathExist shutPidFile >>= \case

184+ Daemon.isRunning shutPidFile >>= \case

185185 True -> do

186186 delaySeconds (Seconds 1)

187187 checkProcessStatus

@@ -206,47 +206,43 @@ data Args = Args

206206

207207

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

209−argParser :: Parser Args

210−argParser = Args <$> commandParser

209+argParser :: CliType -> Parser Args

210+argParser cliType = Args <$> (commandParser cliType)

211211

212212-- ** Top-level command parser

213213

214214-- | CLI commands are parsed into this data-structure by 'commandParser'

215215data Command

216− = Start StartArgs

216+ = Start CommonStartArgs (Maybe UIStartArgs)

217217 | Stop StopArgs

218218 | Status

219219 deriving (Eq, Show)

220220

221221-- Parser for 'argsCommand'

222−commandParser :: Parser Command

223−commandParser = hsubparser

224− ( command "start" (info startParser (progDesc "start the odd-jobs runner")) <>

225− command "stop" (info stopParser (progDesc "stop the odd-jobs runner")) <>

222+commandParser :: CliType -> Parser Command

223+commandParser cliType = hsubparser

224+ ( command "start" (info (startCmdParser cliType) (progDesc "start the odd-jobs runner and/or admin UI")) <>

225+ command "stop" (info stopParser (progDesc "stop the odd-jobs runner and/or admin UI")) <>

226226 command "status" (info statusParser (progDesc "print status of all active jobs"))

227227 )

228228

229+

230+data UIStartArgs = UIStartArgs

231+ { uistartAuth :: !WebUiAuth

232+ , uistartPort :: !Int

233+ } deriving (Eq, Show)

234+

229235-- ** Start command

230236

231237-- | @start@ command is parsed into this data-structure by 'startParser'

232−data StartArgs = StartArgs

233− {

234− -- | Switch to pick the authentication mechanism for web UI. __Note:__ We

235− -- don't have a separate switch to enable\/disable the web UI. Picking an

236− -- authentication mechanism by specifying the relevant options,

237− -- automatically enables the web UI. Ref: 'webUiAuthParser'

238− startWebUiAuth :: !(Maybe WebUiAuth)

239− -- | Port on which the web UI will run.

240− , startWebUiPort :: !Int

241− -- | You'll need to pass the @--daemonize@ switch to fork the job-runner as

242− -- a background daemon, else it will keep running as a foreground process.

243− , startDaemonize :: !Bool

238+data CommonStartArgs = CommonStartArgs

239+ { startDaemonize :: !Bool

244240 -- | PID file for the background dameon. Ref: 'pidFileParser'

245241 , startPidFile :: !FilePath

246242 } deriving (Eq, Show)

247243

248−startParser :: Parser Command

249−startParser = fmap Start $ StartArgs

244+uiStartArgsParser :: Parser UIStartArgs

245+uiStartArgsParser = UIStartArgs

250246 <$> webUiAuthParser

251247 <*> option auto ( long "web-ui-port" <>

252248 metavar "PORT" <>

@@ -254,11 +250,23 @@ startParser = fmap Start $ StartArgs

254250 showDefault <>

255251 help "The port on which the Web UI listens. Please note, to actually enable the Web UI you need to pick one of the available auth schemes"

256252 )

257− <*> switch ( long "daemonize" <>

253+

254+commonStartArgsParser :: Parser CommonStartArgs

255+commonStartArgsParser = CommonStartArgs

256+ <$> switch ( long "daemonize" <>

258257 help "Fork the job-runner as a background daemon. If omitted, the job-runner remains in the foreground."

259258 )

260259 <*> pidFileParser

261260

261+startCmdParser :: CliType -> Parser Command

262+startCmdParser cliType = Start

263+ <$> commonStartArgsParser

264+ <*> (case cliType of

265+ CliOnlyJobRunner _ -> pure Nothing

266+ CliOnlyWebUi _ -> Just <$> uiStartArgsParser

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

268+ )

269+

262270data WebUiAuth

263271 = AuthNone

264272 | AuthBasic !Text !Text

@@ -269,10 +277,10 @@ data WebUiAuth

269277-- * No auth - @--web-ui-no-auth@ __NOT RECOMMENDED__

270278-- * Basic auth - @--web-ui-basic-auth-user <USER>@ and

271279-- @--web-ui-basic-auth-password <PASS>@

272−webUiAuthParser :: Parser (Maybe WebUiAuth)

273−webUiAuthParser = basicAuthParser <|> noAuthParser <|> (pure Nothing)

280+webUiAuthParser :: Parser WebUiAuth

281+webUiAuthParser = basicAuthParser <|> noAuthParser

274282 where

275− basicAuthParser = fmap Just $ AuthBasic

283+ basicAuthParser = AuthBasic

276284 <$> strOption ( long "web-ui-basic-auth-user" <>

277285 metavar "USER" <>

278286 help "Username for basic auth"

@@ -281,7 +289,7 @@ webUiAuthParser = basicAuthParser <|> noAuthParser <|> (pure Nothing)

281289 metavar "PASS" <>

282290 help "Password for basic auth"

283291 )

284− noAuthParser = flag' (Just AuthNone)

292+ noAuthParser = flag' AuthNone

285293 ( long "web-ui-no-auth" <>

286294 help "Start the web UI with any authentication. NOT RECOMMENDED."

287295 )

@@ -335,18 +343,18 @@ defaultCliParserPrefs = prefs $

335343 showHelpOnError <>

336344 showHelpOnEmpty

337345

338−defaultCliInfo :: ParserInfo Args

339−defaultCliInfo =

340− info (argParser <**> helper) fullDesc

341−

342−defaultDaemonOptions :: DaemonOptions

343−defaultDaemonOptions = DaemonOptions

344− { daemonShouldChangeDirectory = False

345− , daemonShouldCloseStandardStreams = False

346− , daemonShouldIgnoreSignals = True

347− , daemonUserToChangeTo = Nothing

348− , daemonGroupToChangeTo = Nothing

349− }

346+defaultCliInfo :: CliType -> ParserInfo Args

347+defaultCliInfo cliType =

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

349+

350+-- defaultDaemonOptions :: DaemonOptions

351+-- defaultDaemonOptions = DaemonOptions

352+-- { daemonShouldChangeDirectory = False

353+-- , daemonShouldCloseStandardStreams = False

354+-- , daemonShouldIgnoreSignals = True

355+-- , daemonUserToChangeTo = Nothing

356+-- , daemonGroupToChangeTo = Nothing

357+-- }

350358

351359

352360-- ** Auth implementations for the default Web UI

src/OddJobs/ConfigBuilder.hs+57−25

@@ -66,17 +66,47 @@ mkConfig logger tname dbpool ccControl jrunner configOverridesFn =

6666 , cfgTableName = tname

6767 , cfgOnJobTimeout = (const $ pure ())

6868 , cfgConcurrencyControl = ccControl

69− , cfgPidFile = Nothing

7069 , cfgJobType = defaultJobType

7170 , cfgDefaultJobTimeout = Seconds 600

72− , cfgJobToHtml = defaultJobToHtml (cfgJobType cfg)

73− , cfgAllJobTypes = (defaultDynamicJobTypes (cfgTableName cfg) (cfgJobTypeSql cfg))

74− , cfgJobTypeSql = defaultJobTypeSql

71+ }

72+ in cfg

73+

74+

75+mkUIConfig :: (LogLevel -> LogEvent -> IO ())

76+ -- ^ "Structured logging" function. Ref: 'uicfgLogger'

77+ -> TableName

78+ -- ^ DB table which holds your jobs. Ref: 'uicfgTableName'

79+ -> Pool Connection

80+ -- ^ DB connection-pool to be used by web UI. Ref: 'uicfgDbPool'

81+ -> (UIConfig -> UIConfig)

82+ -- ^ A function that allows you to modify the \"interim UI config\".

83+ -- The \"interim config\" will cotain a bunch of in-built default

84+ -- config params, along with the config params that you\'ve just

85+ -- provided (i.e. logging function, table name, DB pool, etc). You

86+ -- can use this function to override values in the \"interim UI

87+ -- config\". If you do not wish to modify the \"interim UI config\"

88+ -- just pass 'Prelude.id' as an argument to this parameter. __Note:__

89+ -- it is strongly recommended that you __do not__ modify the

90+ -- generated 'Config' outside of this function, unless you know what

91+ -- you're doing.

92+ -> UIConfig

93+ -- ^ The final 'UIConfig' that needs to be passed to

94+ -- 'OddJobs.Endpoint.mkEnv' and 'OddJobs.Cli.defaultWebUI'

95+mkUIConfig logger tname dbpool configOverridesFn =

96+ let cfg = configOverridesFn $ UIConfig

97+ { uicfgLogger = logger

98+ , uicfgDbPool = dbpool

99+ , uicfgTableName = tname

100+ , uicfgJobType = defaultJobType

101+ , uicfgJobToHtml = defaultJobsToHtml (uicfgJobType cfg)

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

103+ , uicfgJobTypeSql = defaultJobTypeSql

75104 }

76105 in cfg

77106

78107

79108

109+

80110-- | If you aren't interested in structured logging, you can use this function

81111-- to emit plain-text logs (or define your own).

82112defaultLogStr :: (Job -> Text)

@@ -109,28 +139,30 @@ defaultLogStr jobTypeFn logLevel logEvent =

109139 LogText t ->

110140 toLogStr t

111141

142+defaultJobsToHtml :: (Job -> Text)

143+ -> [Job]

144+ -> IO [Html ()]

145+defaultJobsToHtml jobType js = pure $ DL.map (defaultJobToHtml jobType) js

146+

147+

112148defaultJobToHtml :: (Job -> Text)

113− -> [Job]

114− -> IO [Html ()]

115−defaultJobToHtml jobType js =

116− pure $ DL.map jobToHtml js

117− where

118− jobToHtml :: Job -> Html ()

119− jobToHtml j = do

120− div_ [ class_ "job" ] $ do

121− div_ [ class_ "job-type" ] $ do

122− toHtml $ jobType j

123− div_ [ class_ "job-payload" ] $ do

124− defaultPayloadToHtml $ defaultJobContent $ jobPayload j

125− case jobLastError j of

126− Nothing -> mempty

127− Just e -> do

128− div_ [ class_ "job-error collapsed" ] $ do

129− a_ [ href_ "javascript: void(0);", onclick_ "toggleError(this)" ] $ do

130− span_ [ class_ "badge badge-secondary error-expand" ] "+ Last error"

131− span_ [ class_ "badge badge-secondary error-collapse d-none" ] "- Last error"

132− " "

133− defaultErrorToHtml e

149+ -> Job

150+ -> Html ()

151+defaultJobToHtml jobType j =

152+ div_ [ class_ "job" ] $ do

153+ div_ [ class_ "job-type" ] $ do

154+ toHtml $ jobType j

155+ div_ [ class_ "job-payload" ] $ do

156+ defaultPayloadToHtml $ defaultJobContent $ jobPayload j

157+ case jobLastError j of

158+ Nothing -> mempty

159+ Just e -> do

160+ div_ [ class_ "job-error collapsed" ] $ do

161+ a_ [ href_ "javascript: void(0);", onclick_ "toggleError(this)" ] $ do

162+ span_ [ class_ "badge badge-secondary error-expand" ] "+ Last error"

163+ span_ [ class_ "badge badge-secondary error-collapse d-none" ] "- Last error"

164+ " "

165+ defaultErrorToHtml e

134166

135167

136168defaultErrorToHtml :: Value -> Html ()

src/OddJobs/Endpoints.hs+22−22

@@ -74,8 +74,8 @@ data Env = Env

7474 , envJobRunnersRef :: IORef [JobRunnerName]

7575 }

7676

77−mkEnv :: (MonadIO m) => Config -> (Text -> Text) -> m Env

78−mkEnv cfg@Config{..} linksFn = do

77+mkEnv :: (MonadIO m) => UIConfig -> (Text -> Text) -> m Env

78+mkEnv cfg@UIConfig{..} linksFn = do

7979 allJobTypes <- fetchAllJobTypes cfg

8080 allJobRunners <- fetchAllJobRunners cfg

8181 envJobTypesRef <- newIORef allJobTypes

@@ -101,7 +101,7 @@ stopApp = pure ()

101101

102102

103103server :: forall m . (MonadIO m)

104− => Config

104+ => UIConfig

105105 -> Env

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

107107 -> ServerT FinalAPI m

@@ -118,7 +118,7 @@ server cfg env nt =

118118 , rRefreshJobRunners = nt $ refreshJobRunners cfg env

119119 }

120120

121−server2 :: Config

121+server2 :: UIConfig

122122 -> Env

123123 -> Routes AsServer

124124server2 cfg env = Routes

@@ -131,15 +131,15 @@ server2 cfg env = Routes

131131 }

132132

133133

134−refreshJobRunners :: Config

134+refreshJobRunners :: UIConfig

135135 -> Env

136136 -> Handler NoContent

137−refreshJobRunners cfg@Config{..} Env{envRoutes=Web.Routes{..}, envJobRunnersRef} = do

137+refreshJobRunners cfg@UIConfig{..} Env{envRoutes=Web.Routes{..}, envJobRunnersRef} = do

138138 allJobRunners <- fetchAllJobRunners cfg

139139 atomicModifyIORef' envJobRunnersRef (\_ -> (allJobRunners, ()))

140140 throwError $ err302{errHeaders=[("Location", toS $ rFilterResults Nothing)]}

141141

142−refreshJobTypes :: Config

142+refreshJobTypes :: UIConfig

143143 -> Env

144144 -> Handler NoContent

145145refreshJobTypes cfg Env{envRoutes=Web.Routes{..}, envJobTypesRef} = do

@@ -147,30 +147,30 @@ refreshJobTypes cfg Env{envRoutes=Web.Routes{..}, envJobTypesRef} = do

147147 atomicModifyIORef' envJobTypesRef (\_ -> (allJobTypes, ()))

148148 throwError $ err302{errHeaders=[("Location", toS $ rFilterResults Nothing)]}

149149

150−cancelJob :: Config

150+cancelJob :: UIConfig

151151 -> Env

152152 -> JobId

153153 -> Handler NoContent

154−cancelJob Config{..} env jid = do

155− liftIO $ withResource cfgDbPool $ \conn -> void $ cancelJobIO conn cfgTableName jid

154+cancelJob UIConfig{..} env jid = do

155+ liftIO $ withResource uicfgDbPool $ \conn -> void $ cancelJobIO conn uicfgTableName jid

156156 redirectToHome env

157157

158−runJobNow :: Config

158+runJobNow :: UIConfig

159159 -> Env

160160 -> JobId

161161 -> Handler NoContent

162−runJobNow Config{..} env jid = do

163− liftIO $ withResource cfgDbPool $ \conn -> void $ runJobNowIO conn cfgTableName jid

162+runJobNow UIConfig{..} env jid = do

163+ liftIO $ withResource uicfgDbPool $ \conn -> void $ runJobNowIO conn uicfgTableName jid

164164 redirectToHome env

165165

166−enqueueJob :: Config

166+enqueueJob :: UIConfig

167167 -> Env

168168 -> JobId

169169 -> Handler NoContent

170−enqueueJob Config{..} env jid = do

171− liftIO $ withResource cfgDbPool $ \conn -> do

172− void $ unlockJobIO conn cfgTableName jid

173− void $ runJobNowIO conn cfgTableName jid

170+enqueueJob UIConfig{..} env jid = do

171+ liftIO $ withResource uicfgDbPool $ \conn -> do

172+ void $ unlockJobIO conn uicfgTableName jid

173+ void $ runJobNowIO conn uicfgTableName jid

174174 redirectToHome env

175175

176176redirectToHome :: Env -> Handler NoContent

@@ -178,17 +178,17 @@ redirectToHome Env{envRoutes=Web.Routes{..}} = do

178178 throwError $ err301{errHeaders=[("Location", toS $ rFilterResults Nothing)]}

179179

180180

181−filterResults :: Config

181+filterResults :: UIConfig

182182 -> Env

183183 -> Maybe Filter

184184 -> Handler (Html ())

185−filterResults cfg@Config{cfgJobToHtml, cfgDbPool} Env{..} mFilter = do

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

186186 let filters = fromMaybe mempty mFilter

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

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

188188 <$> (filterJobs cfg conn filters)

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

190190 t <- liftIO getCurrentTime

191− js <- liftIO $ fmap (DL.zip jobs) $ cfgJobToHtml jobs

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

192192 allJobTypes <- readIORef envJobTypesRef

193193 let navHtml = Web.sideNav envRoutes allJobTypes [] t filters

194194 bodyHtml = Web.resultsPanel envRoutes t filters js runningCount

src/OddJobs/Job.hs+14−15

@@ -138,7 +138,6 @@ class (MonadUnliftIO m, MonadBaseControl IO m) => HasJobRunner m where

138138 getDefaultMaxAttempts :: m Int

139139 getRunnerEnv :: m RunnerEnv

140140 getConcurrencyControl :: m ConcurrencyControl

141− getPidFile :: m (Maybe FilePath)

142141 log :: LogLevel -> LogEvent -> m ()

143142 getDefaultJobTimeout :: m Seconds

144143

@@ -185,8 +184,6 @@ instance HasJobRunner RunnerM where

185184

186185 getConcurrencyControl = (cfgConcurrencyControl . envConfig <$> ask)

187186

188− getPidFile = cfgPidFile . envConfig <$> ask

189−

190187 log logLevel logEvent = do

191188 loggerFn <- cfgLogger . envConfig <$> ask

192189 liftIO $ loggerFn logLevel logEvent

@@ -199,11 +196,13 @@ instance HasJobRunner RunnerM where

199196-- standalone daemon.

200197startJobRunner :: Config -> IO ()

201198startJobRunner jm = do

199+ traceM "startJobRunner top"

202200 r <- newIORef []

203201 let monitorEnv = RunnerEnv

204202 { envConfig = jm

205203 , envJobThreadsRef = r

206204 }

205+ traceM "before runReaderT"

207206 runReaderT jobMonitor monitorEnv

208207

209208jobWorkerName :: IO String

@@ -423,6 +422,7 @@ runJob jid = do

423422-- TODO: This might have a resource leak.

424423restartUponCrash :: (HasJobRunner m, Show a) => Text -> m a -> m ()

425424restartUponCrash name_ action = do

425+ traceM "restartUponCrash top"

426426 a <- async action

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

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

@@ -432,6 +432,7 @@ restartUponCrash name_ action = do

432432 case x of

433433 Left (e :: SomeException) -> log LevelError $ LogText $ name_ <> " seems to have exited with an error. Restarting: " <> toS (show e)

434434 Right r -> log LevelError $ LogText $ name_ <> " seems to have exited with the folloing result: " <> toS (show r) <> ". Restaring."

435+ traceM "CRASH OCCURRED"

435436 restartUponCrash name_ action

436437

437438-- | Spawns 'jobPoller' and 'jobEventListener' in separate threads and restarts

@@ -440,19 +441,16 @@ restartUponCrash name_ action = do

440441-- executed to finish execution before exiting the main thread.

441442jobMonitor :: forall m . (HasJobRunner m) => m ()

442443jobMonitor = do

444+ traceM "jobMonitor top"

443445 a1 <- async $ restartUponCrash "Job poller" jobPoller

444446 a2 <- async $ restartUponCrash "Job event listener" jobEventListener

447+ traceM "jobMonitor after async"

445448 finally (void $ waitAnyCatch [a1, a2]) $ do

446449 log LevelInfo (LogText "Stopping jobPoller and jobEventListener threads.")

447450 cancel a2

448451 cancel a1

449452 log LevelInfo (LogText "Waiting for jobs to complete.")

450453 waitForJobs

451− getPidFile >>= \case

452− Nothing -> pure ()

453− Just f -> do

454− log LevelInfo $ LogText $ "Removing PID file: " <> toS f

455− liftIO $ Dir.removePathForcibly f

456454

457455-- | Ref: 'jobPoller'

458456jobPollingSql :: Query

@@ -501,6 +499,7 @@ jobPoller = do

501499 pool <- getDbPool

502500 tname <- getTableName

503501 lockTimeout <- getDefaultJobTimeout

502+ traceM "jobPoller just before log statement"

504503 log LevelInfo $ LogText $ toS $ "Starting the job monitor via DB polling with processName=" <> processName

505504 concurrencyControlFn <- getConcurrencyControlFn

506505 withResource pool $ \pollerDbConn -> forever $ concurrencyControlFn >>= \case

@@ -679,12 +678,12 @@ throwParsePayloadWith parser job =

679678-- | Used by the web\/admin UI to fetch a \"master list\" of all known

680679-- job-types. Ref: 'cfgAllJobTypes'

681680fetchAllJobTypes :: (MonadIO m)

682− => Config

681+ => UIConfig

683682 -> m [Text]

684−fetchAllJobTypes Config{cfgAllJobTypes, cfgDbPool} = liftIO $ do

685− case cfgAllJobTypes of

683+fetchAllJobTypes UIConfig{uicfgAllJobTypes, uicfgDbPool} = liftIO $ do

684+ case uicfgAllJobTypes of

686685 AJTFixed jts -> pure jts

687− AJTSql fn -> withResource cfgDbPool fn

686+ AJTSql fn -> withResource uicfgDbPool fn

688687 AJTCustom fn -> fn

689688

690689-- | Used by web\/admin IO to fetch a \"master list\" of all known job-runners.

@@ -694,8 +693,8 @@ fetchAllJobTypes Config{cfgAllJobTypes, cfgDbPool} = liftIO $ do

694693-- discover only those job-runners that are actively executing at least one

695694-- job at the time this function is executed.

696695fetchAllJobRunners :: (MonadIO m)

697− => Config

696+ => UIConfig

698697 -> m [JobRunnerName]

699−fetchAllJobRunners Config{cfgTableName, cfgDbPool} = liftIO $ withResource cfgDbPool $ \conn -> do

700− fmap (mapMaybe fromOnly) $ PGS.query conn "select distinct locked_by from ?" (Only cfgTableName)

698+fetchAllJobRunners UIConfig{uicfgTableName, uicfgDbPool} = liftIO $ withResource uicfgDbPool $ \conn -> do

699+ fmap (mapMaybe fromOnly) $ PGS.query conn "select distinct locked_by from ?" (Only uicfgTableName)

701700

src/OddJobs/Migrations.hs+3

@@ -38,6 +38,7 @@ createNotificationTrigger = "create or replace function ?() returns trigger as $

3838 " return new; \n" <>

3939 "end; \n" <>

4040 "$$ language plpgsql;" <>

41+ "drop trigger if exists ? on ?;" <>

4142 "create trigger ? after insert on ? for each row execute procedure ?();"

4243

4344createJobTable :: Connection -> TableName -> IO ()

@@ -63,6 +64,8 @@ createJobTable conn tname = void $ do

6364 , pgEventName tname

6465 , trgName

6566 , tname

67+ , trgName

68+ , tname

6669 , fnName

6770 )

6871 where

src/OddJobs/Types.hs+39−9

@@ -315,7 +315,7 @@ data Config = Config

315315 -- | File to store the PID of the job-runner process. This is used only when

316316 -- invoking the job-runner as an independent background deemon (the usual mode

317317 -- of deployment).

318− , cfgPidFile :: Maybe FilePath

318+ -- , cfgPidFile :: Maybe FilePath

319319

320320 -- | A "structured logging" function that __you__ need to provide. The

321321 -- @odd-jobs@ library does NOT use the standard logging interface provided by

@@ -331,17 +331,38 @@ data Config = Config

331331 -- 'OddJobs.ConfigBuilder.defaultJobType'

332332 , cfgJobType :: Job -> Text

333333

334+ -- | How long can a job run after which it is considered to be "crashed" and

335+ -- picked up for execution again

336+ , cfgDefaultJobTimeout :: Seconds

337+ }

338+

339+

340+data UIConfig = UIConfig

341+ { -- | The DB table which holds your jobs. Please note, this should have been

342+ -- created by the 'OddJobs.Migrations.createJobTable' function.

343+ uicfgTableName :: TableName

344+

345+ -- | The DB connection-pool to use for the web UI. __Note:__ the same DB

346+ -- pool used by your job-runner can be passed here if it has a sufficient

347+ -- number of connections to satisfy both use-scases. Else create a separate

348+ -- DB pool to be used only by the web UI (this DB pool can have just 1-3

349+ -- connection, because __typically__ the web UI doesn't serve too many

350+ -- concurrent user in most real-life cases)

351+ , uicfgDbPool :: Pool Connection

352+

353+ -- | How to extract the "job type" from a 'Job'. If you are overriding this,

354+ -- please consider overriding 'cfgJobTypeSql' as well. __Note:__ Usually

355+ -- 'cfgJobType' and 'uicfgJobType' would use the same value. Related:

356+ -- 'OddJobs.ConfigBuilder.defaultJobType'

357+ , uicfgJobType :: Job -> Text

358+

334359 -- | How to extract the \"job type\" directly in SQL. There are many places,

335360 -- especially in the web\/admin UI, where we need to know a job's type

336361 -- directly in SQL (because transferrring the entire @payload@ column to

337362 -- Haskell, and then parsing it into JSON, and then applying the

338363 -- 'cfgJobType' function on it would be too inefficient). Ref:

339− -- 'OddJobs.ConfigBuilder.defaultJobTypeSql' and 'cfgJobType'

340− , cfgJobTypeSql :: PGS.Query

341−

342− -- | How long can a job run after which it is considered to be "crashed" and

343− -- picked up for execution again

344− , cfgDefaultJobTimeout :: Seconds

364+ -- 'OddJobs.ConfigBuilder.defaultJobTypeSql' and 'uicfgJobType'

365+ , uicfgJobTypeSql :: PGS.Query

345366

346367 -- | How to convert a list of 'Job's to a list of HTML fragments. This is

347368 -- used in the Web\/Admin UI. This function accepts a /list/ of jobs and

@@ -349,12 +370,21 @@ data Config = Config

349370 -- another table to fetch some metadata (eg. convert a primary-key to a

350371 -- human-readable name), you can do it efficiently instead of resulting in

351372 -- an N+1 SQL bug. Ref: 'defaultJobToHtml'

352− , cfgJobToHtml :: [Job] -> IO [Html ()]

373+ , uicfgJobToHtml :: [Job] -> IO [Html ()]

353374

354375 -- | How to get a list of all known job-types? This is used by the

355376 -- Web\/Admin UI to power the \"filter by job-type\" functionality. The

356377 -- default value for this is 'OddJobs.ConfigBuilder.defaultDynamicJobTypes'

357378 -- which does a @SELECT DISTINCT payload ->> ...@ to get a list of job-types

358379 -- directly from the DB.

359− , cfgAllJobTypes :: AllJobTypes

380+ , uicfgAllJobTypes :: AllJobTypes

381+

382+ -- | A "structured logging" function that __you__ need to provide. The

383+ -- @odd-jobs@ library does NOT use the standard logging interface provided by

384+ -- 'monad-logger' on purpose. Also look at 'cfgJobType' and 'defaultLogStr'

385+ --

386+ -- __Note:__ Please take a look at the section on [structured

387+ -- logging](https://www.haskelltutorials.com/odd-jobs/guide.html#structured-logging)

388+ -- to find out how to use this to log in JSON.

389+ , uicfgLogger :: LogLevel -> LogEvent -> IO ()

360390 }

src/OddJobs/Web.hs+6−6

@@ -126,10 +126,10 @@ data Routes = Routes

126126 }

127127

128128

129−filterJobsQuery :: Config -> Filter -> (PGS.Query, [Action])

130−filterJobsQuery Config{cfgTableName, cfgJobTypeSql} Filter{..} =

129+filterJobsQuery :: UIConfig -> Filter -> (PGS.Query, [Action])

130+filterJobsQuery UIConfig{uicfgTableName, uicfgJobTypeSql} Filter{..} =

131131 ( "SELECT " <> Job.concatJobDbColumns <> " FROM ?" <> whereClause <> " " <> (orderClause $ fromMaybe (OrdUpdatedAt, Desc) filterOrder) <> " " <> limitOffsetClause

132− , (toRow $ Only cfgTableName) ++ whereActions

132+ , (toRow $ Only uicfgTableName) ++ whereActions

133133 )

134134 where

135135 orderClause (flt, dir) =

@@ -172,7 +172,7 @@ filterJobsQuery Config{cfgTableName, cfgJobTypeSql} Filter{..} =

172172 jobTypeClause = case filterJobTypes of

173173 [] -> Nothing

174174 xs ->

175− let qFragment = "(" <> cfgJobTypeSql <> ")=?"

175+ let qFragment = "(" <> uicfgJobTypeSql <> ")=?"

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

177177 [] -> (q, vs)

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

@@ -192,12 +192,12 @@ filterJobsQuery Config{cfgTableName, cfgJobTypeSql} Filter{..} =

192192

193193 -- orderClause = _

194194

195−filterJobs :: Config -> Connection -> Filter -> IO [Job]

195+filterJobs :: UIConfig -> Connection -> Filter -> IO [Job]

196196filterJobs cfg conn f = do

197197 let (q, queryArgs) = filterJobsQuery cfg f

198198 PGS.query conn q queryArgs

199199

200−countJobs :: Config -> Connection -> Filter -> IO Int

200+countJobs :: UIConfig -> Connection -> Filter -> IO Int

201201countJobs cfg conn f = do

202202 let (q, queryArgs) = filterJobsQuery cfg f

203203 finalqry = "SELECT count(*) FROM (" <> q <> ") a"

stack.yaml+2−1

@@ -41,7 +41,8 @@ packages:

4141#

4242extra-deps:

4343 - timing-convenience-0.1@sha256:7ff807a9a9e5596f2b18d45c5a01aefb91d4a98f6a1008d183b5c550f68f7cb7,2092

44− - direct-daemonize-3.1@sha256:f33505932b8613267cd8ad2d51470af2c5708d750ddf55a5dd38292f04962dcc,1630

44+ - daemons-0.3.0@sha256:356edaf06a8cf5e9f19685f9ce793ad6d2b6bce2e55379f6b2aff1b0c07a633f,3178

45+

4546

4647# Override default flag values for local packages and extra-deps

4748# flags: {}