{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}

-- | The hasql database monad with a built-in 'MonadArbiter' instance:
--
-- @
-- import Arbiter.Core qualified as Arb
-- import Arbiter.Hasql qualified as ArbH
-- import Control.Monad (void)
--
-- myFunction :: ArbH.HasqlDb MyRegistry IO ()
-- myFunction = void $ Arb.insertJob (Arb.defaultJob myPayload)
-- @
module Arbiter.Hasql.HasqlDb
  ( -- * Database monad
    HasqlDb (..)
  , HasqlEnv
  , Db
  , Env (..)
  , HasqlConfig (..)
  , PoolState (..)
  , HasPoolState (..)
  , runHasqlDb
  , inTransaction
  , inTransactionWith

    -- * Environment creation
  , HasqlConnect
  , toHasqlConnect
  , acquireConnect
  , createHasqlEnv
  , createHasqlEnvWithConfig
  , createHasqlEnvWithPool
  , destroyHasqlEnv
  , disableListener
  , useDedicatedListener
  , setPreparedStatements

    -- * Hasql settings
  , HasqlSettings
  , hasqlSettings

    -- * Exceptions
  , HasqlConnectionError (..)
  ) where

import Arbiter.Core.Backend
  ( Db (..)
  , Driver (..)
  , Env (..)
  , HasPoolState (..)
  , PoolState (..)
  , createEnvWithConfig
  , createEnvWithPool
  , destroyEnv
  , disableListener
  , runDb
  )
import Arbiter.Core.Backend qualified as Backend
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.Exception (Exception, throwIO)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Class (MonadTrans (..))
import Data.Pool (Pool)
import Data.Proxy (Proxy (..))
import Hasql.Connection qualified as Hasql
import UnliftIO (MonadUnliftIO)

import Arbiter.Hasql.Compat
  ( HasqlConnect
  , HasqlSettings
  , acquireConnect
  , hasqlSettings
  , toHasqlConnect
  , withDedicatedListenConn
  , withHasqlListenConn
  )
import Arbiter.Hasql.MonadArbiter
  ( hasqlExecuteQuery
  , hasqlExecuteQueryPrepared
  , hasqlExecuteStatement
  , hasqlRunHandlerWithConnection
  , hasqlWithDbTransaction
  )

-- | Thrown when a new hasql connection cannot be opened.
newtype HasqlConnectionError = HasqlConnectionError String
  deriving stock (Int -> HasqlConnectionError -> ShowS
[HasqlConnectionError] -> ShowS
HasqlConnectionError -> String
(Int -> HasqlConnectionError -> ShowS)
-> (HasqlConnectionError -> String)
-> ([HasqlConnectionError] -> ShowS)
-> Show HasqlConnectionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HasqlConnectionError -> ShowS
showsPrec :: Int -> HasqlConnectionError -> ShowS
$cshow :: HasqlConnectionError -> String
show :: HasqlConnectionError -> String
$cshowList :: [HasqlConnectionError] -> ShowS
showList :: [HasqlConnectionError] -> ShowS
Show)
  deriving anyclass (Show HasqlConnectionError
Typeable HasqlConnectionError
(Typeable HasqlConnectionError, Show HasqlConnectionError) =>
(HasqlConnectionError -> SomeException)
-> (SomeException -> Maybe HasqlConnectionError)
-> (HasqlConnectionError -> String)
-> (HasqlConnectionError -> Bool)
-> Exception HasqlConnectionError
SomeException -> Maybe HasqlConnectionError
HasqlConnectionError -> Bool
HasqlConnectionError -> String
HasqlConnectionError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: HasqlConnectionError -> SomeException
toException :: HasqlConnectionError -> SomeException
$cfromException :: SomeException -> Maybe HasqlConnectionError
fromException :: SomeException -> Maybe HasqlConnectionError
$cdisplayException :: HasqlConnectionError -> String
displayException :: HasqlConnectionError -> String
$cbacktraceDesired :: HasqlConnectionError -> Bool
backtraceDesired :: HasqlConnectionError -> Bool
Exception)

-- | The 'Env' for 'HasqlDb'.
type HasqlEnv = Env Hasql.Connection HasqlConfig

-- | Driver settings for 'HasqlDb'.
newtype HasqlConfig = HasqlConfig
  { HasqlConfig -> Bool
preparedStatements :: Bool
  -- ^ Prepare hot statements once per connection. Default: 'True'.
  }

hasqlDriver :: Driver Hasql.Connection HasqlConfig
hasqlDriver :: Driver Connection HasqlConfig
hasqlDriver = Driver {withListenConn :: Connection -> (ListenConn -> IO ()) -> IO ()
withListenConn = Connection -> (ListenConn -> IO ()) -> IO ()
forall a. Connection -> (ListenConn -> IO a) -> IO a
withHasqlListenConn, initialConfig :: HasqlConfig
initialConfig = HasqlConfig {preparedStatements :: Bool
preparedStatements = Bool
True}}

-- | The hasql database monad.
newtype HasqlDb (registry :: JobPayloadRegistry) m a = HasqlDb
  { forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlDb registry m a -> Db Connection HasqlConfig registry m a
unHasqlDb :: Db Hasql.Connection HasqlConfig 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 (registry :: JobPayloadRegistry) (m :: * -> *).
Applicative m =>
Functor (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Applicative m =>
a -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Applicative m =>
HasqlDb registry m (a -> b)
-> HasqlDb registry m a -> HasqlDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> HasqlDb registry m a
-> HasqlDb registry m b
-> HasqlDb registry m c
forall a. a -> HasqlDb registry m a
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 (registry :: JobPayloadRegistry) (m :: * -> *) a.
Applicative m =>
a -> HasqlDb registry m a
pure :: forall a. a -> HasqlDb registry m a
$c<*> :: forall (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Functor m =>
a -> HasqlDb registry m b -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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
    , HasPoolState Hasql.Connection
    , 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 (registry :: JobPayloadRegistry) (m :: * -> *).
Monad m =>
Applicative (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Monad m =>
a -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> HasqlDb registry m b -> HasqlDb registry m b
forall (registry :: JobPayloadRegistry) (m :: * -> *) a b.
Monad m =>
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb registry m b
forall a. a -> 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
-> (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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)
-> (forall e a.
    Exception e =>
    HasqlDb registry m a
    -> (ExceptionWithContext e -> HasqlDb registry m a)
    -> HasqlDb registry m a)
-> MonadCatch (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadCatch m =>
MonadThrow (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
HasqlDb registry m a
-> (e -> HasqlDb registry m a) -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
HasqlDb registry m a
-> (ExceptionWithContext 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 e a.
Exception e =>
HasqlDb registry m a
-> (ExceptionWithContext 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)
-> (forall e a.
    Exception e =>
    m a -> (ExceptionWithContext e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (registry :: JobPayloadRegistry) (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
$ccatchNoPropagate :: forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
HasqlDb registry m a
-> (ExceptionWithContext e -> HasqlDb registry m a)
-> HasqlDb registry m a
catchNoPropagate :: forall e a.
Exception e =>
HasqlDb registry m a
-> (ExceptionWithContext e -> HasqlDb registry m a)
-> HasqlDb registry m a
MonadCatch
    , Monad (HasqlDb registry m)
Monad (HasqlDb registry m) =>
(forall a. HasCallStack => String -> HasqlDb registry m a)
-> MonadFail (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadFail m =>
Monad (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> HasqlDb registry m a
forall a. HasCallStack => String -> HasqlDb registry m a
forall (m :: * -> *).
Monad m =>
(forall a. HasCallStack => String -> m a) -> MonadFail m
$cfail :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> HasqlDb registry m a
fail :: forall a. HasCallStack => 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 (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Monad (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
MonadIO m =>
IO a -> HasqlDb registry m a
forall a. IO a -> HasqlDb 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 -> 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 (registry :: JobPayloadRegistry) (m :: * -> *).
MonadMask m =>
MonadCatch (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. HasqlDb registry m a -> HasqlDb registry m a)
 -> HasqlDb registry m b)
-> HasqlDb registry m b
forall (registry :: JobPayloadRegistry) (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 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)
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. 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 (registry :: JobPayloadRegistry) (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 (registry :: JobPayloadRegistry) (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)
-> (forall e a.
    Exception e =>
    ExceptionWithContext e -> HasqlDb registry m a)
-> MonadThrow (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadThrow m =>
Monad (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
ExceptionWithContext e -> HasqlDb registry m a
forall e a.
(HasCallStack, Exception e) =>
e -> HasqlDb registry m a
forall e a.
Exception e =>
ExceptionWithContext e -> HasqlDb registry m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> (forall e a. Exception e => ExceptionWithContext e -> m a)
-> MonadThrow m
$cthrowM :: forall (registry :: JobPayloadRegistry) (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
$crethrowM :: forall (registry :: JobPayloadRegistry) (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
ExceptionWithContext e -> HasqlDb registry m a
rethrowM :: forall e a.
Exception e =>
ExceptionWithContext 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 (registry :: JobPayloadRegistry) (m :: * -> *).
MonadUnliftIO m =>
MonadIO (HasqlDb registry m)
forall (registry :: JobPayloadRegistry) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. HasqlDb registry m a -> IO a) -> IO b)
-> HasqlDb registry m b
forall b.
((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 (registry :: JobPayloadRegistry) (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 MonadTrans (HasqlDb registry) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> HasqlDb registry m a
lift = Db Connection HasqlConfig registry m a -> HasqlDb registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Db Connection HasqlConfig registry m a -> HasqlDb registry m a
HasqlDb (Db Connection HasqlConfig registry m a -> HasqlDb registry m a)
-> (m a -> Db Connection HasqlConfig registry m a)
-> m a
-> HasqlDb registry m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (Env Connection HasqlConfig registry) m a
-> Db Connection HasqlConfig registry m a
forall conn cfg (registry :: JobPayloadRegistry) (m :: * -> *) a.
ReaderT (Env conn cfg registry) m a -> Db conn cfg registry m a
Db (ReaderT (Env Connection HasqlConfig registry) m a
 -> Db Connection HasqlConfig registry m a)
-> (m a -> ReaderT (Env Connection HasqlConfig registry) m a)
-> m a
-> Db Connection HasqlConfig registry m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (Env Connection HasqlConfig registry) m a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (Env Connection HasqlConfig registry) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (MonadUnliftIO m) => MonadArbiter (HasqlDb registry m) where
  type RegistryOf (HasqlDb registry m) = registry
  type Handler (HasqlDb registry m) job result = Hasql.Connection -> job -> HasqlDb registry m result
  getSchema :: HasqlDb registry m SchemaName
getSchema = (Env Connection HasqlConfig registry -> SchemaName)
-> HasqlDb registry m SchemaName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env Connection HasqlConfig registry -> SchemaName
forall conn cfg (registry :: JobPayloadRegistry).
Env conn cfg registry -> SchemaName
schema
  executeQuery :: forall a. Query a -> HasqlDb registry m [a]
executeQuery = Query a -> HasqlDb registry m [a]
forall (m :: * -> *) a.
(HasPoolState Connection m, MonadUnliftIO m) =>
Query a -> m [a]
hasqlExecuteQuery
  executeQueryPrepared :: forall a. Query a -> HasqlDb registry m [a]
executeQueryPrepared Query a
query = (Env Connection HasqlConfig registry -> Bool)
-> HasqlDb registry m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (HasqlConfig -> Bool
preparedStatements (HasqlConfig -> Bool)
-> (Env Connection HasqlConfig registry -> HasqlConfig)
-> Env Connection HasqlConfig registry
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env Connection HasqlConfig registry -> HasqlConfig
forall conn cfg (registry :: JobPayloadRegistry).
Env conn cfg registry -> cfg
driverConfig) HasqlDb registry m Bool
-> (Bool -> HasqlDb registry m [a]) -> HasqlDb registry m [a]
forall a b.
HasqlDb registry m a
-> (a -> HasqlDb registry m b) -> HasqlDb registry m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> Query a -> HasqlDb registry m [a]
forall (m :: * -> *) a.
(HasPoolState Connection m, MonadUnliftIO m) =>
Bool -> Query a -> m [a]
`hasqlExecuteQueryPrepared` Query a
query)
  executeStatement :: forall a. Query a -> HasqlDb registry m Int64
executeStatement = Query a -> HasqlDb registry m Int64
forall (m :: * -> *) a.
(HasPoolState Connection m, MonadUnliftIO m) =>
Query a -> 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.
(HasPoolState Connection m, MonadUnliftIO m) =>
m a -> m a
hasqlWithDbTransaction
  runHandlerWithConnection :: forall payload.
JobHandler
  (HasqlDb registry m)
  payload
  (ResultOf (HasqlDb registry m) payload)
-> JobRead payload
-> HasqlDb registry m (ResultOf (HasqlDb registry m) payload)
runHandlerWithConnection = Handler
  (HasqlDb registry m)
  (JobRecord payload Int64 SchemaName UTCTime PayloadKeys)
  (ResultFor payload (RegistryOf (HasqlDb registry m)))
-> JobRecord payload Int64 SchemaName UTCTime PayloadKeys
-> HasqlDb
     registry m (ResultFor payload (RegistryOf (HasqlDb registry m)))
(Connection
 -> JobRecord payload Int64 SchemaName UTCTime PayloadKeys
 -> HasqlDb registry m (SpecResult (MatchIn payload '[] registry)))
-> JobRecord payload Int64 SchemaName UTCTime PayloadKeys
-> HasqlDb registry m (SpecResult (MatchIn payload '[] registry))
forall (m :: * -> *) job result.
(HasPoolState Connection m, MonadUnliftIO m) =>
(Connection -> job -> m result) -> job -> m result
hasqlRunHandlerWithConnection
  getListener :: HasqlDb registry m (Maybe Listener)
getListener = (Env Connection HasqlConfig registry -> Maybe Listener)
-> HasqlDb registry m (Maybe Listener)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env Connection HasqlConfig registry -> Maybe Listener
forall conn cfg (registry :: JobPayloadRegistry).
Env conn cfg registry -> Maybe Listener
listener

-- | Close the idle connections in the env's pool. Connections in use stay open and go
-- back to the pool. The pool stays usable.
destroyHasqlEnv :: (MonadIO m) => HasqlEnv registry -> m ()
destroyHasqlEnv :: forall (m :: * -> *) (registry :: JobPayloadRegistry).
MonadIO m =>
HasqlEnv registry -> m ()
destroyHasqlEnv = Env Connection HasqlConfig registry -> m ()
forall (m :: * -> *) conn cfg (registry :: JobPayloadRegistry).
MonadIO m =>
Env conn cfg registry -> m ()
destroyEnv

-- | Run a 'HasqlDb' action in its env.
runHasqlDb :: HasqlEnv registry -> HasqlDb registry m a -> m a
runHasqlDb :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlEnv registry -> HasqlDb registry m a -> m a
runHasqlDb HasqlEnv registry
env = HasqlEnv registry -> Db Connection HasqlConfig registry m a -> m a
forall conn cfg (registry :: JobPayloadRegistry) (m :: * -> *) a.
Env conn cfg registry -> Db conn cfg registry m a -> m a
runDb HasqlEnv registry
env (Db Connection HasqlConfig registry m a -> m a)
-> (HasqlDb registry m a -> Db Connection HasqlConfig registry m a)
-> HasqlDb registry m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasqlDb registry m a -> Db Connection HasqlConfig registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlDb registry m a -> Db Connection HasqlConfig registry m a
unHasqlDb

-- | Run a 'HasqlDb' action on one connection pinned as the caller's open transaction.
--
-- @
-- import Arbiter.Core qualified as Arb
-- import Arbiter.Hasql qualified as ArbH
--
-- _ <- Hasql.use conn (Session.script \"BEGIN\")
-- ArbH.inTransaction \@MyRegistry conn \"arbiter\" $ do
--   Arb.insertJob (Arb.defaultJob myPayload)
-- _ <- Hasql.use conn (Session.script \"COMMIT\")
-- @
inTransaction
  :: forall registry m a
   . Hasql.Connection
  -- ^ Connection with an open transaction
  -> SchemaName
  -> HasqlDb registry m a
  -> m a
inTransaction :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
Connection -> SchemaName -> HasqlDb registry m a -> m a
inTransaction = HasqlConfig
-> Connection -> SchemaName -> HasqlDb registry m a -> m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlConfig
-> Connection -> SchemaName -> HasqlDb registry m a -> m a
inTransactionWith (Driver Connection HasqlConfig -> HasqlConfig
forall conn cfg. Driver conn cfg -> cfg
initialConfig Driver Connection HasqlConfig
hasqlDriver)

-- | 'inTransaction' with explicit settings, such as prepared statements off.
inTransactionWith
  :: forall registry m a
   . HasqlConfig
  -- ^ Driver settings
  -> Hasql.Connection
  -- ^ Connection with an open transaction
  -> SchemaName
  -> HasqlDb registry m a
  -> m a
inTransactionWith :: forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlConfig
-> Connection -> SchemaName -> HasqlDb registry m a -> m a
inTransactionWith HasqlConfig
config Connection
conn SchemaName
schemaName =
  Driver Connection HasqlConfig
-> Connection
-> SchemaName
-> Db Connection HasqlConfig registry m a
-> m a
forall conn cfg (registry :: JobPayloadRegistry) (m :: * -> *) a.
Driver conn cfg
-> conn -> SchemaName -> Db conn cfg registry m a -> m a
Backend.inTransaction Driver Connection HasqlConfig
hasqlDriver {initialConfig = config} Connection
conn SchemaName
schemaName (Db Connection HasqlConfig registry m a -> m a)
-> (HasqlDb registry m a -> Db Connection HasqlConfig registry m a)
-> HasqlDb registry m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasqlDb registry m a -> Db Connection HasqlConfig registry m a
forall (registry :: JobPayloadRegistry) (m :: * -> *) a.
HasqlDb registry m a -> Db Connection HasqlConfig registry m a
unHasqlDb

-- | Create a 'HasqlEnv' with 'Arbiter.Core.PoolConfig.defaultPoolConfig'. Size worker pools with
-- 'createHasqlEnvWithConfig' and @Arbiter.Worker.poolConfigForWorkers@.
-- While anything listens, the listener holds one pool slot.
createHasqlEnv
  :: forall registry m
   . (MonadIO m)
  => Proxy registry
  -- ^ Type-level job payload registry
  -> HasqlConnect
  -- ^ Connection settings
  -> SchemaName
  -> m (HasqlEnv registry)
createHasqlEnv :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> HasqlConnect -> SchemaName -> m (HasqlEnv registry)
createHasqlEnv Proxy registry
proxy HasqlConnect
connect SchemaName
schemaName = Proxy registry
-> HasqlConnect
-> SchemaName
-> PoolConfig
-> m (HasqlEnv registry)
forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> HasqlConnect
-> SchemaName
-> PoolConfig
-> m (HasqlEnv registry)
createHasqlEnvWithConfig Proxy registry
proxy HasqlConnect
connect SchemaName
schemaName PoolConfig
PC.defaultPoolConfig

-- | Create a 'HasqlEnv' with custom pool settings. While anything listens, the listener holds
-- one pool slot.
--
-- @
-- let config = PoolConfig
--       { poolSize = 50
--       , poolIdleTimeout = 120
--       , poolStripes = Just 4
--       }
-- env <- createHasqlEnvWithConfig (Proxy \@MyRegistry) (toHasqlConnect Ffi.adapter connStr) "arbiter" config
-- @
createHasqlEnvWithConfig
  :: forall registry m
   . (MonadIO m)
  => Proxy registry
  -- ^ Type-level job payload registry
  -> HasqlConnect
  -- ^ Connection settings
  -> SchemaName
  -> PoolConfig
  -- ^ Pool configuration
  -> m (HasqlEnv registry)
createHasqlEnvWithConfig :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> HasqlConnect
-> SchemaName
-> PoolConfig
-> m (HasqlEnv registry)
createHasqlEnvWithConfig Proxy registry
_proxy HasqlConnect
connect = Driver Connection HasqlConfig
-> IO Connection
-> (Connection -> IO ())
-> SchemaName
-> PoolConfig
-> m (Env Connection HasqlConfig registry)
forall (m :: * -> *) conn cfg (registry :: JobPayloadRegistry).
MonadIO m =>
Driver conn cfg
-> IO conn
-> (conn -> IO ())
-> SchemaName
-> PoolConfig
-> m (Env conn cfg registry)
createEnvWithConfig Driver Connection HasqlConfig
hasqlDriver (HasqlConnect -> IO Connection
acquireOrThrow HasqlConnect
connect) Connection -> IO ()
Hasql.release

-- | Give the env a dedicated LISTEN connection that takes no pool slot.
useDedicatedListener :: (MonadIO m) => HasqlConnect -> HasqlEnv registry -> m (HasqlEnv registry)
useDedicatedListener :: forall (m :: * -> *) (registry :: JobPayloadRegistry).
MonadIO m =>
HasqlConnect -> HasqlEnv registry -> m (HasqlEnv registry)
useDedicatedListener = ((ListenConn -> IO ()) -> IO ())
-> Env Connection HasqlConfig registry
-> m (Env Connection HasqlConfig registry)
forall (m :: * -> *) conn cfg (registry :: JobPayloadRegistry).
MonadIO m =>
((ListenConn -> IO ()) -> IO ())
-> Env conn cfg registry -> m (Env conn cfg registry)
Backend.useDedicatedListener (((ListenConn -> IO ()) -> IO ())
 -> Env Connection HasqlConfig registry
 -> m (Env Connection HasqlConfig registry))
-> (HasqlConnect -> (ListenConn -> IO ()) -> IO ())
-> HasqlConnect
-> Env Connection HasqlConfig registry
-> m (Env Connection HasqlConfig registry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasqlConnect -> (ListenConn -> IO ()) -> IO ()
forall a. HasqlConnect -> (ListenConn -> IO a) -> IO a
withDedicatedListenConn

acquireOrThrow :: HasqlConnect -> IO Hasql.Connection
acquireOrThrow :: HasqlConnect -> IO Connection
acquireOrThrow HasqlConnect
connect = HasqlConnect -> IO (Either String Connection)
acquireConnect HasqlConnect
connect IO (Either String Connection)
-> (Either String Connection -> IO Connection) -> IO Connection
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Connection)
-> (Connection -> IO Connection)
-> Either String Connection
-> IO Connection
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HasqlConnectionError -> IO Connection
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HasqlConnectionError -> IO Connection)
-> (String -> HasqlConnectionError) -> String -> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HasqlConnectionError
HasqlConnectionError) Connection -> IO Connection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Create a 'HasqlEnv' over a caller's own connection pool. While anything listens, the
-- listener holds one pool slot.
createHasqlEnvWithPool
  :: forall registry m
   . (MonadIO m)
  => Proxy registry
  -- ^ Type-level job payload registry
  -> Pool Hasql.Connection
  -- ^ Caller's connection pool
  -> SchemaName
  -> m (HasqlEnv registry)
createHasqlEnvWithPool :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
MonadIO m =>
Proxy registry
-> Pool Connection -> SchemaName -> m (HasqlEnv registry)
createHasqlEnvWithPool Proxy registry
_proxy = Driver Connection HasqlConfig
-> Pool Connection
-> SchemaName
-> m (Env Connection HasqlConfig registry)
forall (m :: * -> *) conn cfg (registry :: JobPayloadRegistry).
MonadIO m =>
Driver conn cfg
-> Pool conn -> SchemaName -> m (Env conn cfg registry)
createEnvWithPool Driver Connection HasqlConfig
hasqlDriver

-- | Enable or disable prepared statements on the hot path. On by default. Needs direct
-- connections or a pooler that supports them.
setPreparedStatements :: Bool -> HasqlEnv registry -> HasqlEnv registry
setPreparedStatements :: forall (registry :: JobPayloadRegistry).
Bool -> HasqlEnv registry -> HasqlEnv registry
setPreparedStatements Bool
flag HasqlEnv registry
env = HasqlEnv registry
env {driverConfig = HasqlConfig {preparedStatements = flag}}