Resource limit

.gitignore

@@ -2,3 +2,5 @@ stack.yaml.lock
 test.log
 TAGS
 .stack-work/
+dist-*
+cabal.project.local*

dev/DevelDb.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Provides tools to facilitate database interactions during interactive
+-- development.
+module DevelDb where
+
+import           Control.Exception (bracket)
+import           Data.Aeson(FromJSON, ToJSON)
+import           Data.ByteString.Char8 (ByteString, pack)
+import           Data.Text (Text)
+import qualified Database.PostgreSQL.Simple as PGS
+import           System.Environment (lookupEnv)
+
+import GHC.Generics
+
+import OddJobs.Migrations
+import OddJobs.Job
+import OddJobs.Types
+
+data TestJob = TestJob Text
+  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+
+devTableNames :: TableNames
+devTableNames = TableNames
+  { tnJob = "job", tnResource = "resource" }
+
+devConnectionString :: IO ByteString
+devConnectionString = do
+  maybe (error "devConnectionString: Expected environment variable \"ODD_JOBS_DEV_DB_CONNECT\" to provide a connection string")
+        pack
+    <$> lookupEnv "ODD_JOBS_DEV_DB_CONNECT"
+
+createDevDatabase :: IO ()
+createDevDatabase = do
+  connStr <- devConnectionString
+  conn <- PGS.connectPostgreSQL connStr
+  PGS.withTransaction conn $ createJobTables conn devTableNames
+
+openDevConnection :: IO PGS.Connection
+openDevConnection = devConnectionString >>= PGS.connectPostgreSQL
+
+withDevConnection :: (PGS.Connection -> IO a) -> IO a
+withDevConnection = bracket openDevConnection PGS.close
+
+withDevTransaction :: (PGS.Connection -> IO a) -> IO a
+withDevTransaction act =
+  withDevConnection $ \conn -> PGS.withTransaction conn (act conn)

odd-jobs.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e6616995768a7a1fd8654b632013cf28cfa6e31926533c4470e8e970d1d2d3bd
+-- hash: 559bd60bc7a5df63861a213412268e713c83719c49399149be8dcbcc620aa0e5
 
 name:           odd-jobs
 version:        0.2.2
@@ -103,6 +103,7 @@ library
 executable devel
   main-is: DevelMain.hs
   other-modules:
+      DevelDb
       OddJobs.Cli
       OddJobs.ConfigBuilder
       OddJobs.Endpoints
@@ -207,11 +208,18 @@ test-suite jobrunner
   main-is: Test.hs
   other-modules:
       CliParser
-      Try
-      Try2
+      OddJobs.Cli
+      OddJobs.ConfigBuilder
+      OddJobs.Endpoints
+      OddJobs.Job
+      OddJobs.Migrations
+      OddJobs.Types
+      OddJobs.Web
+      UI
       Paths_odd_jobs
   hs-source-dirs:
       test
+      src
   default-extensions: NamedFieldPuns LambdaCase TemplateHaskell ScopedTypeVariables GeneralizedNewtypeDeriving QuasiQuotes OverloadedStrings
   ghc-options: -Wall -fno-warn-orphans -fno-warn-unused-imports -fno-warn-dodgy-exports -Werror=missing-fields -threaded -with-rtsopts=-N -main-is Test
   build-depends:
@@ -235,7 +243,6 @@ test-suite jobrunner
     , monad-control
     , monad-logger
     , mtl
-    , odd-jobs
     , optparse-applicative
     , postgresql-simple
     , random

package.yaml

@@ -133,13 +133,14 @@ tests:
       - -threaded
       - -with-rtsopts=-N
     main: Test
-    source-dirs: test
+    source-dirs:
+      - test
+      - src
     dependencies:
       - tasty
       - tasty-discover
       - hedgehog
       - tasty-hedgehog
-      - odd-jobs
       - tasty-hunit
       - random
       - monad-control

src/OddJobs/ConfigBuilder.hs

@@ -34,7 +34,7 @@ import qualified System.Log.FastLogger as FLogger
 mkConfig :: (LogLevel -> LogEvent -> IO ())
          -- ^ "Structured logging" function. Ref: 'cfgLogger'
          -> TableName
-         -- ^ DB table which holds your jobs. Ref: 'cfgTableName'
+         -- ^ DB table which holds your jobs (resource table name will be generated). Ref: 'cfgTableNames'
          -> Pool Connection
          -- ^ DB connection-pool to be used by job-runner. Ref: 'cfgDbPool'
          -> ConcurrencyControl
@@ -53,7 +53,39 @@ mkConfig :: (LogLevel -> LogEvent -> IO ())
          -- function, unless you know what you're doing.
          -> Config
          -- ^ The final 'Config' that can be used to start various job-runners
-mkConfig logger tname dbpool ccControl jrunner configOverridesFn =
+mkConfig logger tname =
+  mkResourceConfig logger (simpleTableNames tname)
+
+-- | This function gives you a 'Config' with a bunch of sensible defaults
+-- already applied, but it allows the specification of all database table
+-- names.. It requires the bare minimum of other configuration parameters that
+-- this library cannot assume on your behalf.
+--
+-- It makes a few __important assumptions__ about your 'jobPayload 'JSON, which
+-- are documented in 'defaultJobType'.
+mkResourceConfig :: (LogLevel -> LogEvent -> IO ())
+                 -- ^ "Structured logging" function. Ref: 'cfgLogger'
+                 -> TableNames
+                 -- ^ DB tables which hold your jobs and resources
+                 -> Pool Connection
+                 -- ^ DB connection-pool to be used by job-runner. Ref: 'cfgDbPool'
+                 -> ConcurrencyControl
+                 -- ^ Concurrency configuration. Ref: 'cfgConcurrencyControl'
+                 -> (Job -> IO ())
+                 -- ^ The actual "job runner" which contains your application code. Ref: 'cfgJobRunner'
+                 -> (Config -> Config)
+                 -- ^ A function that allows you to modify the \"interim config\". The
+                 -- \"interim config\" will cotain a bunch of in-built default config
+                 -- params, along with the config params that you\'ve just provided
+                 -- (i.e. logging function, table name, DB pool, etc). You can use this
+                 -- function to override values in the \"interim config\". If you do not
+                 -- wish to modify the \"interim config\" just pass 'Prelude.id' as an
+                 -- argument to this parameter. __Note:__ it is strongly recommended
+                 -- that you __do not__ modify the generated 'Config' outside of this
+                 -- function, unless you know what you're doing.
+                 -> Config
+                 -- ^ The final 'Config' that can be used to start various job-runners
+mkResourceConfig logger tnames dbpool ccControl jrunner configOverridesFn =
   let cfg = configOverridesFn $ Config
             { cfgPollingInterval = defaultPollingInterval
             , cfgOnJobSuccess = (const $ pure ())
@@ -63,20 +95,20 @@ mkConfig logger tname dbpool ccControl jrunner configOverridesFn =
             , cfgDbPool = dbpool
             , cfgOnJobStart = (const $ pure ())
             , cfgDefaultMaxAttempts = 10
-            , cfgTableName = tname
+            , cfgTableNames = tnames
             , cfgOnJobTimeout = (const $ pure ())
             , cfgConcurrencyControl = ccControl
+            , cfgDefaultResourceLimit = 1
             , cfgPidFile = Nothing
             , cfgJobType = defaultJobType
             , cfgDefaultJobTimeout = Seconds 600
             , cfgJobToHtml = defaultJobToHtml (cfgJobType cfg)
-            , cfgAllJobTypes = (defaultDynamicJobTypes (cfgTableName cfg) (cfgJobTypeSql cfg))
+            , cfgAllJobTypes = (defaultDynamicJobTypes (cfgTableNames cfg) (cfgJobTypeSql cfg))
             , cfgJobTypeSql = defaultJobTypeSql
             }
   in cfg
 
 
-
 -- | If you aren't interested in structured logging, you can use this function
 -- to emit plain-text logs (or define your own).
 defaultLogStr :: (Job -> Text)
@@ -184,11 +216,12 @@ defaultConstantJobTypes :: forall a . (Generic a, ConNames (Rep a))
 defaultConstantJobTypes _ =
   AJTFixed $ DL.map toS $ conNames (undefined :: a)
 
-defaultDynamicJobTypes :: TableName
+defaultDynamicJobTypes :: TableNames
                        -> PGS.Query
                        -> AllJobTypes
-defaultDynamicJobTypes tname jobTypeSql = AJTSql $ \conn -> do
-  fmap (DL.map ((fromMaybe "(unknown)") . fromOnly)) $ PGS.query_ conn $ "select distinct(" <> jobTypeSql <> ") from " <> tname <> " order by 1 nulls last"
+defaultDynamicJobTypes tnames jobTypeSql = AJTSql $ \conn -> do
+  fmap (DL.map ((fromMaybe "(unknown)") . fromOnly)) $ PGS.query_ conn $
+    "select distinct(" <> jobTypeSql <> ") from " <> tnJob tnames <> " order by 1 nulls last"
 
 -- | This makes __two important assumptions__. First, this /assumes/ that jobs
 -- in your app are represented by a sum-type. For example:

src/OddJobs/Endpoints.hs

@@ -152,15 +152,15 @@ cancelJob :: Config
           -> JobId
           -> Handler NoContent
 cancelJob Config{..} env jid = do
-  liftIO $ withResource cfgDbPool $ \conn -> void $ cancelJobIO conn cfgTableName jid
+  liftIO $ withResource cfgDbPool $ \conn -> void $ cancelJobIO conn cfgTableNames jid
   redirectToHome env
 
 runJobNow :: Config
           -> Env
           -> JobId
           -> Handler NoContent
 runJobNow Config{..} env jid = do
-  liftIO $ withResource cfgDbPool $ \conn -> void $ runJobNowIO conn cfgTableName jid
+  liftIO $ withResource cfgDbPool $ \conn -> void $ runJobNowIO conn cfgTableNames jid
   redirectToHome env
 
 enqueueJob :: Config
@@ -169,8 +169,8 @@ enqueueJob :: Config
            -> Handler NoContent
 enqueueJob Config{..} env jid = do
   liftIO $ withResource cfgDbPool $ \conn -> do
-    void $ unlockJobIO conn cfgTableName jid
-    void $ runJobNowIO conn cfgTableName jid
+    void $ unlockJobIO conn cfgTableNames jid
+    void $ runJobNowIO conn cfgTableNames jid
   redirectToHome env
 
 redirectToHome :: Env -> Handler NoContent