{-# LANGUAGE TypeFamilies #-}

-- | Simple database monad for Arbiter with postgresql-simple backend.
--
-- 'SimpleDb' has a built-in 'MonadArbiter' instance, so you can use it directly:
--
-- @
-- import Arbiter.Core
-- import Arbiter.Simple
--
-- myFunction :: SimpleDb MyRegistry IO ()
-- myFunction = insertJob (defaultJob myPayload)
-- @
module Arbiter.Simple.SimpleDb
  ( -- * Database Monad
    SimpleDb (..)
  , SimpleEnv (..)
  , runSimpleDb
  , inTransaction

    -- * Environment Creation
  , createSimpleEnv
  , createSimpleEnvWithConfig
  , createSimpleEnvWithPool
  ) where

import Arbiter.Core.HasArbiterSchema (HasArbiterSchema (..))
import Arbiter.Core.Job.Schema (SchemaName)
import Arbiter.Core.MonadArbiter (MonadArbiter (..))
import Arbiter.Core.PoolConfig (PoolConfig (..))
import Arbiter.Core.PoolConfig qualified as PC
import Arbiter.Core.QueueRegistry (JobPayloadRegistry)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, asks, local)
import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
import Data.ByteString (ByteString)
import Data.Pool (Pool, defaultPoolConfig, newPool, setNumStripes)
import Data.Proxy (Proxy (..))
import Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
import UnliftIO (MonadUnliftIO)

import Arbiter.Simple.MonadArbiter
  ( HasSimplePool (..)
  , SimpleConnectionPool (..)
  , simpleExecuteQuery
  , simpleExecuteStatement
  , simpleRunHandlerWithConnection
  , simpleWithDbTransaction
  )

-- | Schema name and connection pool for 'SimpleDb'.
data SimpleEnv (registry :: JobPayloadRegistry) = SimpleEnv
  { forall (registry :: JobPayloadRegistry).
SimpleEnv registry -> SchemaName
schema :: SchemaName
  -- ^ Schema name
  , forall (registry :: JobPayloadRegistry).
SimpleEnv registry -> SimpleConnectionPool
simplePool :: SimpleConnectionPool
  -- ^ The connection pool state
  }

-- | Simple database monad using postgresql-simple.
newtype SimpleDb (registry :: JobPayloadRegistry) m a = SimpleDb {forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
SimpleDb registry m a -> ReaderT (SimpleEnv registry) m a
unSimpleDb :: ReaderT (SimpleEnv registry) m a}
  deriving newtype
    ( Functor (SimpleDb registry m)
Functor (SimpleDb registry m) =>
(forall a. a -> SimpleDb registry m a)
-> (forall a b.
    SimpleDb registry m (a -> b)
    -> SimpleDb registry m a -> SimpleDb registry m b)
-> (forall a b c.
    (a -> b -> c)
    -> SimpleDb registry m a
    -> SimpleDb registry m b
    -> SimpleDb registry m c)
-> (forall a b.
    SimpleDb registry m a
    -> SimpleDb registry m b -> SimpleDb registry m b)
-> (forall a b.
    SimpleDb registry m a
    -> SimpleDb registry m b -> SimpleDb registry m a)
-> Applicative (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
Applicative m =>
Functor (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Applicative m =>
a -> SimpleDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m (a -> b)
-> SimpleDb registry m a -> SimpleDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SimpleDb registry m a
-> SimpleDb registry m b
-> SimpleDb registry m c
forall a. a -> SimpleDb registry m a
forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m a
forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
forall a b.
SimpleDb registry m (a -> b)
-> SimpleDb registry m a -> SimpleDb registry m b
forall a b c.
(a -> b -> c)
-> SimpleDb registry m a
-> SimpleDb registry m b
-> SimpleDb registry m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Applicative m =>
a -> SimpleDb registry m a
pure :: forall a. a -> SimpleDb registry m a
$c<*> :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m (a -> b)
-> SimpleDb registry m a -> SimpleDb registry m b
<*> :: forall a b.
SimpleDb registry m (a -> b)
-> SimpleDb registry m a -> SimpleDb registry m b
$cliftA2 :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SimpleDb registry m a
-> SimpleDb registry m b
-> SimpleDb registry m c
liftA2 :: forall a b c.
(a -> b -> c)
-> SimpleDb registry m a
-> SimpleDb registry m b
-> SimpleDb registry m c
$c*> :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
*> :: forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
$c<* :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m a
<* :: forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m a
Applicative
    , (forall a b.
 (a -> b) -> SimpleDb registry m a -> SimpleDb registry m b)
-> (forall a b.
    a -> SimpleDb registry m b -> SimpleDb registry m a)
-> Functor (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Functor m =>
a -> SimpleDb registry m b -> SimpleDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Functor m =>
(a -> b) -> SimpleDb registry m a -> SimpleDb registry m b
forall a b. a -> SimpleDb registry m b -> SimpleDb registry m a
forall a b.
(a -> b) -> SimpleDb registry m a -> SimpleDb registry m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Functor m =>
(a -> b) -> SimpleDb registry m a -> SimpleDb registry m b
fmap :: forall a b.
(a -> b) -> SimpleDb registry m a -> SimpleDb registry m b
$c<$ :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Functor m =>
a -> SimpleDb registry m b -> SimpleDb registry m a
<$ :: forall a b. a -> SimpleDb registry m b -> SimpleDb registry m a
Functor
    , Applicative (SimpleDb registry m)
Applicative (SimpleDb registry m) =>
(forall a b.
 SimpleDb registry m a
 -> (a -> SimpleDb registry m b) -> SimpleDb registry m b)
-> (forall a b.
    SimpleDb registry m a
    -> SimpleDb registry m b -> SimpleDb registry m b)
-> (forall a. a -> SimpleDb registry m a)
-> Monad (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
Monad m =>
Applicative (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Monad m =>
a -> SimpleDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
SimpleDb registry m a
-> (a -> SimpleDb registry m b) -> SimpleDb registry m b
forall a. a -> SimpleDb registry m a
forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
forall a b.
SimpleDb registry m a
-> (a -> SimpleDb registry m b) -> SimpleDb registry m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
SimpleDb registry m a
-> (a -> SimpleDb registry m b) -> SimpleDb registry m b
>>= :: forall a b.
SimpleDb registry m a
-> (a -> SimpleDb registry m b) -> SimpleDb registry m b
$c>> :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
>> :: forall a b.
SimpleDb registry m a
-> SimpleDb registry m b -> SimpleDb registry m b
$creturn :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Monad m =>
a -> SimpleDb registry m a
return :: forall a. a -> SimpleDb registry m a
Monad
    , MonadThrow (SimpleDb registry m)
MonadThrow (SimpleDb registry m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 SimpleDb registry m a
 -> (e -> SimpleDb registry m a) -> SimpleDb registry m a)
-> MonadCatch (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadCatch m =>
MonadThrow (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SimpleDb registry m a
-> (e -> SimpleDb registry m a) -> SimpleDb registry m a
forall e a.
(HasCallStack, Exception e) =>
SimpleDb registry m a
-> (e -> SimpleDb registry m a) -> SimpleDb registry m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SimpleDb registry m a
-> (e -> SimpleDb registry m a) -> SimpleDb registry m a
catch :: forall e a.
(HasCallStack, Exception e) =>
SimpleDb registry m a
-> (e -> SimpleDb registry m a) -> SimpleDb registry m a
MonadCatch
    , Monad (SimpleDb registry m)
Monad (SimpleDb registry m) =>
(forall a. String -> SimpleDb registry m a)
-> MonadFail (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadFail m =>
Monad (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
MonadFail m =>
String -> SimpleDb registry m a
forall a. String -> SimpleDb registry m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
MonadFail m =>
String -> SimpleDb registry m a
fail :: forall a. String -> SimpleDb registry m a
MonadFail
    , Monad (SimpleDb registry m)
Monad (SimpleDb registry m) =>
(forall a. IO a -> SimpleDb registry m a)
-> MonadIO (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Monad (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
MonadIO m =>
IO a -> SimpleDb registry m a
forall a. IO a -> SimpleDb registry m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
MonadIO m =>
IO a -> SimpleDb registry m a
liftIO :: forall a. IO a -> SimpleDb registry m a
MonadIO
    , MonadCatch (SimpleDb registry m)
MonadCatch (SimpleDb registry m) =>
(forall b.
 HasCallStack =>
 ((forall a. SimpleDb registry m a -> SimpleDb registry m a)
  -> SimpleDb registry m b)
 -> SimpleDb registry m b)
-> (forall b.
    HasCallStack =>
    ((forall a. SimpleDb registry m a -> SimpleDb registry m a)
     -> SimpleDb registry m b)
    -> SimpleDb registry m b)
-> (forall a b c.
    HasCallStack =>
    SimpleDb registry m a
    -> (a -> ExitCase b -> SimpleDb registry m c)
    -> (a -> SimpleDb registry m b)
    -> SimpleDb registry m (b, c))
-> MonadMask (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadMask m =>
MonadCatch (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
SimpleDb registry m a
-> (a -> ExitCase b -> SimpleDb registry m c)
-> (a -> SimpleDb registry m b)
-> SimpleDb registry m (b, c)
forall b.
HasCallStack =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
forall a b c.
HasCallStack =>
SimpleDb registry m a
-> (a -> ExitCase b -> SimpleDb registry m c)
-> (a -> SimpleDb registry m b)
-> SimpleDb registry m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
mask :: forall b.
HasCallStack =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
$cuninterruptibleMask :: forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SimpleDb registry m a -> SimpleDb registry m a)
 -> SimpleDb registry m b)
-> SimpleDb registry m b
$cgeneralBracket :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
SimpleDb registry m a
-> (a -> ExitCase b -> SimpleDb registry m c)
-> (a -> SimpleDb registry m b)
-> SimpleDb registry m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
SimpleDb registry m a
-> (a -> ExitCase b -> SimpleDb registry m c)
-> (a -> SimpleDb registry m b)
-> SimpleDb registry m (b, c)
MonadMask
    , MonadReader (SimpleEnv registry)
    , Monad (SimpleDb registry m)
Monad (SimpleDb registry m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 e -> SimpleDb registry m a)
-> MonadThrow (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadThrow m =>
Monad (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SimpleDb registry m a
forall e a.
(HasCallStack, Exception e) =>
e -> SimpleDb registry m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SimpleDb registry m a
throwM :: forall e a.
(HasCallStack, Exception e) =>
e -> SimpleDb registry m a
MonadThrow
    , MonadIO (SimpleDb registry m)
MonadIO (SimpleDb registry m) =>
(forall b.
 ((forall a. SimpleDb registry m a -> IO a) -> IO b)
 -> SimpleDb registry m b)
-> MonadUnliftIO (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadUnliftIO m =>
MonadIO (SimpleDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. SimpleDb registry m a -> IO a) -> IO b)
-> SimpleDb registry m b
forall b.
((forall a. SimpleDb registry m a -> IO a) -> IO b)
-> SimpleDb registry m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. SimpleDb registry m a -> IO a) -> IO b)
-> SimpleDb registry m b
withRunInIO :: forall b.
((forall a. SimpleDb registry m a -> IO a) -> IO b)
-> SimpleDb registry m b
MonadUnliftIO
    )

instance (Monad m) => HasArbiterSchema (SimpleDb registry m) registry where
  getSchema :: SimpleDb registry m SchemaName
getSchema = (SimpleEnv registry -> SchemaName)
-> SimpleDb registry m SchemaName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SimpleEnv registry -> SchemaName
forall (registry :: JobPayloadRegistry).
SimpleEnv registry -> SchemaName
schema

instance (Monad m) => HasSimplePool (SimpleDb registry m) where
  getSimplePool :: SimpleDb registry m SimpleConnectionPool
getSimplePool = (SimpleEnv registry -> SimpleConnectionPool)
-> SimpleDb registry m SimpleConnectionPool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SimpleEnv registry -> SimpleConnectionPool
forall (registry :: JobPayloadRegistry).
SimpleEnv registry -> SimpleConnectionPool
simplePool
  localSimplePool :: forall a.
(SimpleConnectionPool -> SimpleConnectionPool)
-> SimpleDb registry m a -> SimpleDb registry m a
localSimplePool SimpleConnectionPool -> SimpleConnectionPool
f = (SimpleEnv registry -> SimpleEnv registry)
-> SimpleDb registry m a -> SimpleDb registry m a
forall a.
(SimpleEnv registry -> SimpleEnv registry)
-> SimpleDb registry m a -> SimpleDb registry m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\SimpleEnv registry
env -> SimpleEnv registry
env {simplePool = f (simplePool env)})

instance (Monad m, MonadIO m, MonadUnliftIO m) => MonadArbiter (SimpleDb registry m) where
  type Handler (SimpleDb registry m) jobs result = Connection -> jobs -> SimpleDb registry m result
  executeQuery :: forall a.
SchemaName -> Params -> RowCodec a -> SimpleDb registry m [a]
executeQuery = SchemaName -> Params -> RowCodec a -> SimpleDb registry m [a]
forall (m :: * -> *) a.
(HasSimplePool m, MonadUnliftIO m) =>
SchemaName -> Params -> RowCodec a -> m [a]
simpleExecuteQuery
  executeStatement :: SchemaName -> Params -> SimpleDb registry m Int64
executeStatement = SchemaName -> Params -> SimpleDb registry m Int64
forall (m :: * -> *).
(HasSimplePool m, MonadUnliftIO m) =>
SchemaName -> Params -> m Int64
simpleExecuteStatement
  withDbTransaction :: forall a. SimpleDb registry m a -> SimpleDb registry m a
withDbTransaction = SimpleDb registry m a -> SimpleDb registry m a
forall (m :: * -> *) a.
(HasSimplePool m, MonadUnliftIO m) =>
m a -> m a
simpleWithDbTransaction
  runHandlerWithConnection :: forall jobs result.
Handler (SimpleDb registry m) jobs result
-> jobs -> SimpleDb registry m result
runHandlerWithConnection = Handler (SimpleDb registry m) jobs result
-> jobs -> SimpleDb registry m result
(Connection -> jobs -> SimpleDb registry m result)
-> jobs -> SimpleDb registry m result
forall (m :: * -> *) jobs result.
(HasSimplePool m, MonadUnliftIO m) =>
(Connection -> jobs -> m result) -> jobs -> m result
simpleRunHandlerWithConnection

-- | Run a SimpleDb action with a SimpleEnv.
runSimpleDb :: SimpleEnv registry -> SimpleDb registry m a -> m a
runSimpleDb :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
SimpleEnv registry -> SimpleDb registry m a -> m a
runSimpleDb SimpleEnv registry
env SimpleDb registry m a
action = ReaderT (SimpleEnv registry) m a -> SimpleEnv registry -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SimpleDb registry m a -> ReaderT (SimpleEnv registry) m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
SimpleDb registry m a -> ReaderT (SimpleEnv registry) m a
unSimpleDb SimpleDb registry m a
action) SimpleEnv registry
env

-- | Run a SimpleDb action using a single postgresql-simple connection.
--
-- No pool or env is needed. The connection is pinned with @transactionDepth = 1@,
-- so arbiter's 'withDbTransaction' uses savepoints instead of issuing @BEGIN@.
-- The caller is responsible for transaction lifecycle on the connection.
--
-- @
-- PG.withTransaction conn $ do
--   PG.execute conn "INSERT INTO orders ..." params
--   inTransaction conn "arbiter" $
--     Arb.insertJob (Arb.defaultJob (ProcessOrder orderId))
-- @
inTransaction
  :: forall registry m a
   . Connection
  -> SchemaName
  -- ^ Schema name
  -> SimpleDb registry m a
  -> m a
inTransaction :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Connection -> SchemaName -> SimpleDb registry m a -> m a
inTransaction Connection
conn SchemaName
schemaName SimpleDb registry m a
action =
  let env :: SimpleEnv registry
env =
        SimpleEnv
          { schema :: SchemaName
schema = SchemaName
schemaName
          , simplePool :: SimpleConnectionPool
simplePool =
              SimpleConnectionPool
                { connectionPool :: Maybe (Pool Connection)
connectionPool = Maybe (Pool Connection)
forall a. Maybe a
Nothing
                , activeConn :: Maybe Connection
activeConn = Connection -> Maybe Connection
forall a. a -> Maybe a
Just Connection
conn
                , transactionDepth :: Int
transactionDepth = Int
1
                }
          }
   in SimpleEnv registry -> SimpleDb registry m a -> m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
SimpleEnv registry -> SimpleDb registry m a -> m a
runSimpleDb SimpleEnv registry
env SimpleDb registry m a
action

-- | Create a 'SimpleEnv' with default pool settings (10 connections, 300s idle, 1 stripe).
-- For workers, use 'createSimpleEnvWithConfig' with 'poolConfigForWorkers' instead.
createSimpleEnv
  :: forall registry m
   . (MonadIO m)
  => Proxy registry
  -- ^ Type-level job payload registry
  -> ByteString
  -- ^ PostgreSQL connection string
  -> SchemaName
  -- ^ Schema name
  -> m (SimpleEnv registry)
createSimpleEnv :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> ByteString -> SchemaName -> m (SimpleEnv registry)
createSimpleEnv Proxy registry
proxy ByteString
connStr SchemaName
schemaName =
  Proxy registry
-> ByteString -> SchemaName -> PoolConfig -> m (SimpleEnv registry)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> ByteString -> SchemaName -> PoolConfig -> m (SimpleEnv registry)
createSimpleEnvWithConfig Proxy registry
proxy ByteString
connStr SchemaName
schemaName PoolConfig
PC.defaultPoolConfig

-- | Create a 'SimpleEnv' with custom pool settings.
--
-- Example:
--
-- @
-- let config = PoolConfig
--       { poolSize = 50
--       , poolIdleTimeout = 120
--       , poolStripes = Just 4
--       }
-- env <- createSimpleEnvWithConfig (Proxy @MyRegistry) "host=localhost dbname=mydb" "arbiter" config
-- @
createSimpleEnvWithConfig
  :: forall registry m
   . (MonadIO m)
  => Proxy registry
  -- ^ Type-level job payload registry
  -> ByteString
  -- ^ PostgreSQL connection string
  -> SchemaName
  -- ^ Schema name
  -> PoolConfig
  -- ^ Pool configuration
  -> m (SimpleEnv registry)
createSimpleEnvWithConfig :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> ByteString -> SchemaName -> PoolConfig -> m (SimpleEnv registry)
createSimpleEnvWithConfig Proxy registry
_proxy ByteString
connStr SchemaName
schemaName PoolConfig
config = IO (SimpleEnv registry) -> m (SimpleEnv registry)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SimpleEnv registry) -> m (SimpleEnv registry))
-> IO (SimpleEnv registry) -> m (SimpleEnv registry)
forall a b. (a -> b) -> a -> b
$ do
  let stripes :: Maybe Int
stripes = PoolConfig -> Maybe Int
poolStripes PoolConfig
config
  connPool <-
    PoolConfig Connection -> IO (Pool Connection)
forall a. PoolConfig a -> IO (Pool a)
newPool (PoolConfig Connection -> IO (Pool Connection))
-> PoolConfig Connection -> IO (Pool Connection)
forall a b. (a -> b) -> a -> b
$
      Maybe Int -> PoolConfig Connection -> PoolConfig Connection
forall a. Maybe Int -> PoolConfig a -> PoolConfig a
setNumStripes Maybe Int
stripes (PoolConfig Connection -> PoolConfig Connection)
-> PoolConfig Connection -> PoolConfig Connection
forall a b. (a -> b) -> a -> b
$
        IO Connection
-> (Connection -> IO ()) -> Double -> Int -> PoolConfig Connection
forall a. IO a -> (a -> IO ()) -> Double -> Int -> PoolConfig a
defaultPoolConfig
          (ByteString -> IO Connection
connectPostgreSQL ByteString
connStr)
          Connection -> IO ()
close
          (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ PoolConfig -> Int
poolIdleTimeout PoolConfig
config) -- idle time (seconds)
          (PoolConfig -> Int
poolSize PoolConfig
config)
  pure
    SimpleEnv
      { schema = schemaName
      , simplePool = SimpleConnectionPool {connectionPool = Just connPool, activeConn = Nothing, transactionDepth = 0}
      }

-- | Create a SimpleEnv with a user-provided connection pool
createSimpleEnvWithPool
  :: forall registry
   . Proxy registry
  -- ^ Type-level job payload registry
  -> Pool Connection
  -- ^ User-provided connection pool
  -> SchemaName
  -- ^ Schema name
  -> SimpleEnv registry
createSimpleEnvWithPool :: forall (registry :: JobPayloadRegistry).
Proxy registry
-> Pool Connection -> SchemaName -> SimpleEnv registry
createSimpleEnvWithPool Proxy registry
_proxy Pool Connection
connPool SchemaName
schemaName =
  SimpleEnv
    { schema :: SchemaName
schema = SchemaName
schemaName
    , simplePool :: SimpleConnectionPool
simplePool = SimpleConnectionPool {connectionPool :: Maybe (Pool Connection)
connectionPool = Pool Connection -> Maybe (Pool Connection)
forall a. a -> Maybe a
Just Pool Connection
connPool, activeConn :: Maybe Connection
activeConn = Maybe Connection
forall a. Maybe a
Nothing, transactionDepth :: Int
transactionDepth = Int
0}
    }