{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Hasql database monad for Arbiter.
--
-- 'HasqlDb' has a built-in 'MonadArbiter' instance, so you can use it directly:
--
-- @
-- import Arbiter.Core
-- import Arbiter.Hasql
--
-- myFunction :: HasqlDb MyRegistry IO ()
-- myFunction = insertJob (defaultJob myPayload)
-- @
module Arbiter.Hasql.HasqlDb
  ( -- * Database Monad
    HasqlDb (..)
  , HasqlEnv (..)
  , runHasqlDb
  , inTransaction

    -- * Environment Creation
  , createHasqlEnv
  , createHasqlEnvWithConfig
  , createHasqlEnvWithPool

    -- * Hasql Settings
  , hasqlSettings
  ) where

import Arbiter.Core.HasArbiterSchema (HasArbiterSchema (..))
import Arbiter.Core.MonadArbiter (MonadArbiter (..))
import Arbiter.Core.PoolConfig (PoolConfig (..))
import Arbiter.Core.PoolConfig qualified as PC
import Arbiter.Core.QueueRegistry (AllQueuesUnique)
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 Data.Text (Text)
import Hasql.Connection qualified as Hasql
import UnliftIO (MonadUnliftIO)

import Arbiter.Hasql.Compat qualified as Compat
import Arbiter.Hasql.MonadArbiter
  ( HasHasqlPool (..)
  , HasqlConnectionPool (..)
  , hasqlExecuteQuery
  , hasqlExecuteStatement
  , hasqlRunHandlerWithConnection
  , hasqlWithDbTransaction
  )

-- | Environment for HasqlDb operations
--
-- Contains both the schema name and the connection pool.
data HasqlEnv registry = HasqlEnv
  { forall {k} (registry :: k). HasqlEnv registry -> Text
schema :: Text
  -- ^ PostgreSQL schema name where job tables are located
  , forall {k} (registry :: k).
HasqlEnv registry -> HasqlConnectionPool
hasqlPool :: HasqlConnectionPool
  -- ^ The connection pool state
  }

-- | Hasql database monad for Arbiter.
newtype HasqlDb registry m a = HasqlDb {forall {k} (registry :: k) (m :: * -> *) a.
HasqlDb registry m a -> ReaderT (HasqlEnv registry) m a
unHasqlDb :: ReaderT (HasqlEnv registry) m a}
  deriving newtype
    ( Functor (HasqlDb registry m)
Functor (HasqlDb registry m) =>
(forall a. a -> HasqlDb registry m a)
-> (forall a b.
    HasqlDb registry m (a -> b)
    -> HasqlDb registry m a -> HasqlDb registry m b)
-> (forall a b c.
    (a -> b -> c)
    -> HasqlDb registry m a
    -> HasqlDb registry m b
    -> HasqlDb registry m c)
-> (forall a b.
    HasqlDb registry m a
    -> HasqlDb registry m b -> HasqlDb registry m b)
-> (forall a b.
    HasqlDb registry m a
    -> HasqlDb registry m b -> HasqlDb registry m a)
-> Applicative (HasqlDb registry m)
forall a. a -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *).
Applicative m =>
Functor (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) a.
Applicative m =>
a -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m (a -> b)
-> HasqlDb registry m a -> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> HasqlDb registry m a
-> HasqlDb registry m b
-> HasqlDb registry m c
forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m a
forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall a b.
HasqlDb registry m (a -> b)
-> HasqlDb registry m a -> HasqlDb registry m b
forall a b c.
(a -> b -> c)
-> HasqlDb registry m a
-> HasqlDb registry m b
-> HasqlDb 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 k (registry :: k) (m :: * -> *) a.
Applicative m =>
a -> HasqlDb registry m a
pure :: forall a. a -> HasqlDb registry m a
$c<*> :: forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m (a -> b)
-> HasqlDb registry m a -> HasqlDb registry m b
<*> :: forall a b.
HasqlDb registry m (a -> b)
-> HasqlDb registry m a -> HasqlDb registry m b
$cliftA2 :: forall k (registry :: k) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> HasqlDb registry m a
-> HasqlDb registry m b
-> HasqlDb registry m c
liftA2 :: forall a b c.
(a -> b -> c)
-> HasqlDb registry m a
-> HasqlDb registry m b
-> HasqlDb registry m c
$c*> :: forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
*> :: forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
$c<* :: forall k (registry :: k) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m a
<* :: forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m a
Applicative
    , (forall a b.
 (a -> b) -> HasqlDb registry m a -> HasqlDb registry m b)
-> (forall a b. a -> HasqlDb registry m b -> HasqlDb registry m a)
-> Functor (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) a b.
Functor m =>
a -> HasqlDb registry m b -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *) a b.
Functor m =>
(a -> b) -> HasqlDb registry m a -> HasqlDb registry m b
forall a b. a -> HasqlDb registry m b -> HasqlDb registry m a
forall a b.
(a -> b) -> HasqlDb registry m a -> HasqlDb 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 k (registry :: k) (m :: * -> *) a b.
Functor m =>
(a -> b) -> HasqlDb registry m a -> HasqlDb registry m b
fmap :: forall a b.
(a -> b) -> HasqlDb registry m a -> HasqlDb registry m b
$c<$ :: forall k (registry :: k) (m :: * -> *) a b.
Functor m =>
a -> HasqlDb registry m b -> HasqlDb registry m a
<$ :: forall a b. a -> HasqlDb registry m b -> HasqlDb registry m a
Functor
    , Applicative (HasqlDb registry m)
Applicative (HasqlDb registry m) =>
(forall a b.
 HasqlDb registry m a
 -> (a -> HasqlDb registry m b) -> HasqlDb registry m b)
-> (forall a b.
    HasqlDb registry m a
    -> HasqlDb registry m b -> HasqlDb registry m b)
-> (forall a. a -> HasqlDb registry m a)
-> Monad (HasqlDb registry m)
forall a. a -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *).
Monad m =>
Applicative (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) a.
Monad m =>
a -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb registry m b
forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall a b.
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb 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 k (registry :: k) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb registry m b
>>= :: forall a b.
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb registry m b
$c>> :: forall k (registry :: k) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
>> :: forall a b.
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
$creturn :: forall k (registry :: k) (m :: * -> *) a.
Monad m =>
a -> HasqlDb registry m a
return :: forall a. a -> HasqlDb registry m a
Monad
    , MonadThrow (HasqlDb registry m)
MonadThrow (HasqlDb registry m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 HasqlDb registry m a
 -> (e -> HasqlDb registry m a) -> HasqlDb registry m a)
-> MonadCatch (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *).
MonadCatch m =>
MonadThrow (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
HasqlDb registry m a
-> (e -> HasqlDb registry m a) -> HasqlDb registry m a
forall e a.
(HasCallStack, Exception e) =>
HasqlDb registry m a
-> (e -> HasqlDb registry m a) -> HasqlDb registry m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall k (registry :: k) (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
HasqlDb registry m a
-> (e -> HasqlDb registry m a) -> HasqlDb registry m a
catch :: forall e a.
(HasCallStack, Exception e) =>
HasqlDb registry m a
-> (e -> HasqlDb registry m a) -> HasqlDb registry m a
MonadCatch
    , Monad (HasqlDb registry m)
Monad (HasqlDb registry m) =>
(forall a. String -> HasqlDb registry m a)
-> MonadFail (HasqlDb registry m)
forall a. String -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *).
MonadFail m =>
Monad (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) a.
MonadFail m =>
String -> HasqlDb registry m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall k (registry :: k) (m :: * -> *) a.
MonadFail m =>
String -> HasqlDb registry m a
fail :: forall a. String -> HasqlDb registry m a
MonadFail
    , Monad (HasqlDb registry m)
Monad (HasqlDb registry m) =>
(forall a. IO a -> HasqlDb registry m a)
-> MonadIO (HasqlDb registry m)
forall a. IO a -> HasqlDb registry m a
forall k (registry :: k) (m :: * -> *).
MonadIO m =>
Monad (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) a.
MonadIO m =>
IO a -> HasqlDb registry m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall k (registry :: k) (m :: * -> *) a.
MonadIO m =>
IO a -> HasqlDb registry m a
liftIO :: forall a. IO a -> HasqlDb registry m a
MonadIO
    , MonadCatch (HasqlDb registry m)
MonadCatch (HasqlDb registry m) =>
(forall b.
 HasCallStack =>
 ((forall a. HasqlDb registry m a -> HasqlDb registry m a)
  -> HasqlDb registry m b)
 -> HasqlDb registry m b)
-> (forall b.
    HasCallStack =>
    ((forall a. HasqlDb registry m a -> HasqlDb registry m a)
     -> HasqlDb registry m b)
    -> HasqlDb registry m b)
-> (forall a b c.
    HasCallStack =>
    HasqlDb registry m a
    -> (a -> ExitCase b -> HasqlDb registry m c)
    -> (a -> HasqlDb registry m b)
    -> HasqlDb registry m (b, c))
-> MonadMask (HasqlDb registry m)
forall b.
HasCallStack =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *).
MonadMask m =>
MonadCatch (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
HasqlDb registry m a
-> (a -> ExitCase b -> HasqlDb registry m c)
-> (a -> HasqlDb registry m b)
-> HasqlDb registry m (b, c)
forall a b c.
HasCallStack =>
HasqlDb registry m a
-> (a -> ExitCase b -> HasqlDb registry m c)
-> (a -> HasqlDb registry m b)
-> HasqlDb 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 k (registry :: k) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
mask :: forall b.
HasCallStack =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
$cuninterruptibleMask :: forall k (registry :: k) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
$cgeneralBracket :: forall k (registry :: k) (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
HasqlDb registry m a
-> (a -> ExitCase b -> HasqlDb registry m c)
-> (a -> HasqlDb registry m b)
-> HasqlDb registry m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
HasqlDb registry m a
-> (a -> ExitCase b -> HasqlDb registry m c)
-> (a -> HasqlDb registry m b)
-> HasqlDb registry m (b, c)
MonadMask
    , MonadReader (HasqlEnv registry)
    , Monad (HasqlDb registry m)
Monad (HasqlDb registry m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 e -> HasqlDb registry m a)
-> MonadThrow (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *).
MonadThrow m =>
Monad (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> HasqlDb registry m a
forall e a.
(HasCallStack, Exception e) =>
e -> HasqlDb registry m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall k (registry :: k) (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> HasqlDb registry m a
throwM :: forall e a.
(HasCallStack, Exception e) =>
e -> HasqlDb registry m a
MonadThrow
    , MonadIO (HasqlDb registry m)
MonadIO (HasqlDb registry m) =>
(forall b.
 ((forall a. HasqlDb registry m a -> IO a) -> IO b)
 -> HasqlDb registry m b)
-> MonadUnliftIO (HasqlDb registry m)
forall b.
((forall a. HasqlDb registry m a -> IO a) -> IO b)
-> HasqlDb registry m b
forall k (registry :: k) (m :: * -> *).
MonadUnliftIO m =>
MonadIO (HasqlDb registry m)
forall k (registry :: k) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. HasqlDb registry m a -> IO a) -> IO b)
-> HasqlDb registry m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall k (registry :: k) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. HasqlDb registry m a -> IO a) -> IO b)
-> HasqlDb registry m b
withRunInIO :: forall b.
((forall a. HasqlDb registry m a -> IO a) -> IO b)
-> HasqlDb registry m b
MonadUnliftIO
    )

instance (Monad m) => HasArbiterSchema (HasqlDb registry m) registry where
  getSchema :: HasqlDb registry m Text
getSchema = (HasqlEnv registry -> Text) -> HasqlDb registry m Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HasqlEnv registry -> Text
forall {k} (registry :: k). HasqlEnv registry -> Text
schema

instance (Monad m) => HasHasqlPool (HasqlDb registry m) where
  getHasqlPool :: HasqlDb registry m HasqlConnectionPool
getHasqlPool = (HasqlEnv registry -> HasqlConnectionPool)
-> HasqlDb registry m HasqlConnectionPool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HasqlEnv registry -> HasqlConnectionPool
forall {k} (registry :: k).
HasqlEnv registry -> HasqlConnectionPool
hasqlPool
  localHasqlPool :: forall a.
(HasqlConnectionPool -> HasqlConnectionPool)
-> HasqlDb registry m a -> HasqlDb registry m a
localHasqlPool HasqlConnectionPool -> HasqlConnectionPool
f = (HasqlEnv registry -> HasqlEnv registry)
-> HasqlDb registry m a -> HasqlDb registry m a
forall a.
(HasqlEnv registry -> HasqlEnv registry)
-> HasqlDb registry m a -> HasqlDb registry m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\HasqlEnv registry
env -> HasqlEnv registry
env {hasqlPool = f (hasqlPool env)})

instance (Monad m, MonadIO m, MonadUnliftIO m) => MonadArbiter (HasqlDb registry m) where
  type Handler (HasqlDb registry m) jobs result = Hasql.Connection -> jobs -> HasqlDb registry m result
  executeQuery :: forall a. Text -> Params -> RowCodec a -> HasqlDb registry m [a]
executeQuery = Text -> Params -> RowCodec a -> HasqlDb registry m [a]
forall (m :: * -> *) a.
(HasHasqlPool m, MonadIO m) =>
Text -> Params -> RowCodec a -> m [a]
hasqlExecuteQuery
  executeStatement :: Text -> Params -> HasqlDb registry m Int64
executeStatement = Text -> Params -> HasqlDb registry m Int64
forall (m :: * -> *).
(HasHasqlPool m, MonadIO m) =>
Text -> Params -> m Int64
hasqlExecuteStatement
  withDbTransaction :: forall a. HasqlDb registry m a -> HasqlDb registry m a
withDbTransaction = HasqlDb registry m a -> HasqlDb registry m a
forall (m :: * -> *) a.
(HasHasqlPool m, MonadUnliftIO m) =>
m a -> m a
hasqlWithDbTransaction
  runHandlerWithConnection :: forall jobs result.
Handler (HasqlDb registry m) jobs result
-> jobs -> HasqlDb registry m result
runHandlerWithConnection = Handler (HasqlDb registry m) jobs result
-> jobs -> HasqlDb registry m result
(Connection -> jobs -> HasqlDb registry m result)
-> jobs -> HasqlDb registry m result
forall (m :: * -> *) jobs result.
(HasHasqlPool m, MonadIO m) =>
(Connection -> jobs -> m result) -> jobs -> m result
hasqlRunHandlerWithConnection

-- | Run a HasqlDb action with a HasqlEnv.
runHasqlDb :: HasqlEnv registry -> HasqlDb registry m a -> m a
runHasqlDb :: forall {k} (registry :: k) (m :: * -> *) a.
HasqlEnv registry -> HasqlDb registry m a -> m a
runHasqlDb HasqlEnv registry
env HasqlDb registry m a
action = ReaderT (HasqlEnv registry) m a -> HasqlEnv registry -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (HasqlDb registry m a -> ReaderT (HasqlEnv registry) m a
forall {k} (registry :: k) (m :: * -> *) a.
HasqlDb registry m a -> ReaderT (HasqlEnv registry) m a
unHasqlDb HasqlDb registry m a
action) HasqlEnv registry
env

-- | Run a HasqlDb action using a single hasql connection.
--
-- No pool 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.
--
-- @
-- _ <- Hasql.use conn (Session.script "BEGIN")
-- inTransaction conn "arbiter" $ do
--   Arb.insertJob (Arb.defaultJob myPayload)
-- _ <- Hasql.use conn (Session.script "COMMIT")
-- @
inTransaction
  :: forall registry m a
   . Hasql.Connection
  -> Text
  -- ^ PostgreSQL schema name
  -> HasqlDb registry m a
  -> m a
inTransaction :: forall {k} (registry :: k) (m :: * -> *) a.
Connection -> Text -> HasqlDb registry m a -> m a
inTransaction Connection
conn Text
schemaName HasqlDb registry m a
action =
  let env :: HasqlEnv registry
env =
        HasqlEnv
          { schema :: Text
schema = Text
schemaName
          , hasqlPool :: HasqlConnectionPool
hasqlPool =
              HasqlConnectionPool
                { 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 HasqlEnv registry -> HasqlDb registry m a -> m a
forall {k} (registry :: k) (m :: * -> *) a.
HasqlEnv registry -> HasqlDb registry m a -> m a
runHasqlDb HasqlEnv registry
env HasqlDb registry m a
action

-- | Create a HasqlEnv with conservative defaults (10 connections, 300s idle timeout, 1 stripe).
--
-- For worker pools, consider using 'createHasqlEnvWithConfig' with @poolConfigForWorkers@
-- to size the pool based on worker count.
createHasqlEnv
  :: forall registry m
   . (AllQueuesUnique registry, MonadIO m)
  => Proxy registry
  -> ByteString
  -- ^ PostgreSQL connection string
  -> Text
  -- ^ PostgreSQL schema name (e.g., "arbiter")
  -> m (HasqlEnv registry)
createHasqlEnv :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
(AllQueuesUnique registry, MonadIO m) =>
Proxy registry -> ByteString -> Text -> m (HasqlEnv registry)
createHasqlEnv Proxy registry
proxy ByteString
connStr Text
schemaName =
  Proxy registry
-> ByteString -> Text -> PoolConfig -> m (HasqlEnv registry)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
(AllQueuesUnique registry, MonadIO m) =>
Proxy registry
-> ByteString -> Text -> PoolConfig -> m (HasqlEnv registry)
createHasqlEnvWithConfig Proxy registry
proxy ByteString
connStr Text
schemaName PoolConfig
PC.defaultPoolConfig

-- | Create a HasqlEnv with custom pool configuration.
createHasqlEnvWithConfig
  :: forall registry m
   . (AllQueuesUnique registry, MonadIO m)
  => Proxy registry
  -> ByteString
  -- ^ PostgreSQL connection string
  -> Text
  -- ^ PostgreSQL schema name
  -> PoolConfig
  -> m (HasqlEnv registry)
createHasqlEnvWithConfig :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
(AllQueuesUnique registry, MonadIO m) =>
Proxy registry
-> ByteString -> Text -> PoolConfig -> m (HasqlEnv registry)
createHasqlEnvWithConfig Proxy registry
_proxy ByteString
connStr Text
schemaName PoolConfig
config = IO (HasqlEnv registry) -> m (HasqlEnv registry)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HasqlEnv registry) -> m (HasqlEnv registry))
-> IO (HasqlEnv registry) -> m (HasqlEnv registry)
forall a b. (a -> b) -> a -> b
$ do
  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 (PoolConfig -> Maybe Int
poolStripes PoolConfig
config) (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
          ( do
              result <- Settings -> IO (Either ConnectionError Connection)
Hasql.acquire (ByteString -> Settings
hasqlSettings ByteString
connStr)
              case result of
                Right Connection
conn -> Connection -> IO Connection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
                Left ConnectionError
err -> String -> IO Connection
forall a. HasCallStack => String -> a
error (String -> IO Connection) -> String -> IO Connection
forall a b. (a -> b) -> a -> b
$ String
"hasql: connection failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ConnectionError -> String
forall a. Show a => a -> String
show ConnectionError
err
          )
          Connection -> IO ()
Hasql.release
          (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)
          (PoolConfig -> Int
poolSize PoolConfig
config)
  pure
    HasqlEnv
      { schema = schemaName
      , hasqlPool = HasqlConnectionPool {connectionPool = Just connPool, activeConn = Nothing, transactionDepth = 0}
      }

-- | Create a HasqlEnv with a user-provided connection pool.
createHasqlEnvWithPool
  :: forall registry
   . (AllQueuesUnique registry)
  => Proxy registry
  -> Pool Hasql.Connection
  -> Text
  -- ^ PostgreSQL schema name
  -> HasqlEnv registry
createHasqlEnvWithPool :: forall (registry :: JobPayloadRegistry).
AllQueuesUnique registry =>
Proxy registry -> Pool Connection -> Text -> HasqlEnv registry
createHasqlEnvWithPool Proxy registry
_proxy Pool Connection
connPool Text
schemaName =
  HasqlEnv
    { schema :: Text
schema = Text
schemaName
    , hasqlPool :: HasqlConnectionPool
hasqlPool = HasqlConnectionPool {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}
    }

-- | Re-exported from "Arbiter.Hasql.Compat".
hasqlSettings :: ByteString -> Compat.HasqlSettings
hasqlSettings :: ByteString -> Settings
hasqlSettings = ByteString -> Settings
Compat.hasqlSettings