{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.PostgreSQL.Tx.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** Internals
    module Database.PostgreSQL.Tx.Internal
  ) where

import Control.Exception (Exception(toException), SomeException, catch, throwIO)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT))
import Data.Kind (Constraint)
import GHC.TypeLits (ErrorMessage(Text), TypeError)

-- | The transaction monad. Unifies all database integrations, regardless of
-- library, into a single monad. The @r@ type parameter represents the reader
-- environment needed for applicable database libraries. For example,
-- @postgresql-simple@ needs a @Connection@ to run its functions, so
-- its interface will require that we can obtain a @Connection@ from the @r@
-- using the 'TxEnv' type class.
--
-- @since 0.2.0.0
newtype TxM r a = UnsafeTxM
  { -- | Convert a 'TxM' action to raw 'ReaderT' over 'IO'. This is provided only to give
    -- adaptor libraries access to the underlying 'IO' that 'TxM' wraps.
    --
    -- @since 0.2.0.0
    TxM r a -> ReaderT r IO a
unsafeUnTxM :: ReaderT r IO a
  } deriving newtype (a -> TxM r b -> TxM r a
(a -> b) -> TxM r a -> TxM r b
(forall a b. (a -> b) -> TxM r a -> TxM r b)
-> (forall a b. a -> TxM r b -> TxM r a) -> Functor (TxM r)
forall a b. a -> TxM r b -> TxM r a
forall a b. (a -> b) -> TxM r a -> TxM r b
forall r a b. a -> TxM r b -> TxM r a
forall r a b. (a -> b) -> TxM r a -> TxM r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TxM r b -> TxM r a
$c<$ :: forall r a b. a -> TxM r b -> TxM r a
fmap :: (a -> b) -> TxM r a -> TxM r b
$cfmap :: forall r a b. (a -> b) -> TxM r a -> TxM r b
Functor, Functor (TxM r)
a -> TxM r a
Functor (TxM r)
-> (forall a. a -> TxM r a)
-> (forall a b. TxM r (a -> b) -> TxM r a -> TxM r b)
-> (forall a b c. (a -> b -> c) -> TxM r a -> TxM r b -> TxM r c)
-> (forall a b. TxM r a -> TxM r b -> TxM r b)
-> (forall a b. TxM r a -> TxM r b -> TxM r a)
-> Applicative (TxM r)
TxM r a -> TxM r b -> TxM r b
TxM r a -> TxM r b -> TxM r a
TxM r (a -> b) -> TxM r a -> TxM r b
(a -> b -> c) -> TxM r a -> TxM r b -> TxM r c
forall r. Functor (TxM r)
forall a. a -> TxM r a
forall r a. a -> TxM r a
forall a b. TxM r a -> TxM r b -> TxM r a
forall a b. TxM r a -> TxM r b -> TxM r b
forall a b. TxM r (a -> b) -> TxM r a -> TxM r b
forall r a b. TxM r a -> TxM r b -> TxM r a
forall r a b. TxM r a -> TxM r b -> TxM r b
forall r a b. TxM r (a -> b) -> TxM r a -> TxM r b
forall a b c. (a -> b -> c) -> TxM r a -> TxM r b -> TxM r c
forall r a b c. (a -> b -> c) -> TxM r a -> TxM r b -> TxM r 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
<* :: TxM r a -> TxM r b -> TxM r a
$c<* :: forall r a b. TxM r a -> TxM r b -> TxM r a
*> :: TxM r a -> TxM r b -> TxM r b
$c*> :: forall r a b. TxM r a -> TxM r b -> TxM r b
liftA2 :: (a -> b -> c) -> TxM r a -> TxM r b -> TxM r c
$cliftA2 :: forall r a b c. (a -> b -> c) -> TxM r a -> TxM r b -> TxM r c
<*> :: TxM r (a -> b) -> TxM r a -> TxM r b
$c<*> :: forall r a b. TxM r (a -> b) -> TxM r a -> TxM r b
pure :: a -> TxM r a
$cpure :: forall r a. a -> TxM r a
$cp1Applicative :: forall r. Functor (TxM r)
Applicative, Applicative (TxM r)
a -> TxM r a
Applicative (TxM r)
-> (forall a b. TxM r a -> (a -> TxM r b) -> TxM r b)
-> (forall a b. TxM r a -> TxM r b -> TxM r b)
-> (forall a. a -> TxM r a)
-> Monad (TxM r)
TxM r a -> (a -> TxM r b) -> TxM r b
TxM r a -> TxM r b -> TxM r b
forall r. Applicative (TxM r)
forall a. a -> TxM r a
forall r a. a -> TxM r a
forall a b. TxM r a -> TxM r b -> TxM r b
forall a b. TxM r a -> (a -> TxM r b) -> TxM r b
forall r a b. TxM r a -> TxM r b -> TxM r b
forall r a b. TxM r a -> (a -> TxM r b) -> TxM r 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
return :: a -> TxM r a
$creturn :: forall r a. a -> TxM r a
>> :: TxM r a -> TxM r b -> TxM r b
$c>> :: forall r a b. TxM r a -> TxM r b -> TxM r b
>>= :: TxM r a -> (a -> TxM r b) -> TxM r b
$c>>= :: forall r a b. TxM r a -> (a -> TxM r b) -> TxM r b
$cp1Monad :: forall r. Applicative (TxM r)
Monad, Monad (TxM r)
Monad (TxM r) -> (forall a. String -> TxM r a) -> MonadFail (TxM r)
String -> TxM r a
forall r. Monad (TxM r)
forall a. String -> TxM r a
forall r a. String -> TxM r a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> TxM r a
$cfail :: forall r a. String -> TxM r a
$cp1MonadFail :: forall r. Monad (TxM r)
MonadFail)
    deriving (b -> TxM r a -> TxM r a
NonEmpty (TxM r a) -> TxM r a
TxM r a -> TxM r a -> TxM r a
(TxM r a -> TxM r a -> TxM r a)
-> (NonEmpty (TxM r a) -> TxM r a)
-> (forall b. Integral b => b -> TxM r a -> TxM r a)
-> Semigroup (TxM r a)
forall b. Integral b => b -> TxM r a -> TxM r a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall r a. Semigroup a => NonEmpty (TxM r a) -> TxM r a
forall r a. Semigroup a => TxM r a -> TxM r a -> TxM r a
forall r a b. (Semigroup a, Integral b) => b -> TxM r a -> TxM r a
stimes :: b -> TxM r a -> TxM r a
$cstimes :: forall r a b. (Semigroup a, Integral b) => b -> TxM r a -> TxM r a
sconcat :: NonEmpty (TxM r a) -> TxM r a
$csconcat :: forall r a. Semigroup a => NonEmpty (TxM r a) -> TxM r a
<> :: TxM r a -> TxM r a -> TxM r a
$c<> :: forall r a. Semigroup a => TxM r a -> TxM r a -> TxM r a
Semigroup, Semigroup (TxM r a)
TxM r a
Semigroup (TxM r a)
-> TxM r a
-> (TxM r a -> TxM r a -> TxM r a)
-> ([TxM r a] -> TxM r a)
-> Monoid (TxM r a)
[TxM r a] -> TxM r a
TxM r a -> TxM r a -> TxM r a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall r a. Monoid a => Semigroup (TxM r a)
forall r a. Monoid a => TxM r a
forall r a. Monoid a => [TxM r a] -> TxM r a
forall r a. Monoid a => TxM r a -> TxM r a -> TxM r a
mconcat :: [TxM r a] -> TxM r a
$cmconcat :: forall r a. Monoid a => [TxM r a] -> TxM r a
mappend :: TxM r a -> TxM r a -> TxM r a
$cmappend :: forall r a. Monoid a => TxM r a -> TxM r a -> TxM r a
mempty :: TxM r a
$cmempty :: forall r a. Monoid a => TxM r a
$cp1Monoid :: forall r a. Monoid a => Semigroup (TxM r a)
Monoid) via (r -> IO a)

-- | Run an 'IO' action in 'TxM'. Use this function with care - arbitrary 'IO'
-- should only be run within a transaction when truly necessary.
--
-- @since 0.2.0.0
unsafeRunIOInTxM :: IO a -> TxM r a
unsafeRunIOInTxM :: IO a -> TxM r a
unsafeRunIOInTxM = ReaderT r IO a -> TxM r a
forall r a. ReaderT r IO a -> TxM r a
UnsafeTxM (ReaderT r IO a -> TxM r a)
-> (IO a -> ReaderT r IO a) -> IO a -> TxM r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Construct a 'TxM' using a reader function. Use this function with care -
-- arbitrary 'IO' should only be run within a transaction when truly necessary.
--
-- @since 0.2.0.0
unsafeMkTxM :: (r -> IO a) -> TxM r a
unsafeMkTxM :: (r -> IO a) -> TxM r a
unsafeMkTxM = ReaderT r IO a -> TxM r a
forall r a. ReaderT r IO a -> TxM r a
UnsafeTxM (ReaderT r IO a -> TxM r a)
-> ((r -> IO a) -> ReaderT r IO a) -> (r -> IO a) -> TxM r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> IO a) -> ReaderT r IO a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT

-- | Similar to 'unsafeMkTxM' but allows for constructing a 'TxM' with a
-- reader function using a specific value from the environment.
-- Use this function with care - arbitrary 'IO' should only be run
-- within a transaction when truly necessary.
--
-- @since 0.2.0.0
unsafeMksTxM :: (TxEnv a r) => (a -> IO b) -> TxM r b
unsafeMksTxM :: (a -> IO b) -> TxM r b
unsafeMksTxM a -> IO b
f =
  (r -> IO b) -> TxM r b
forall r a. (r -> IO a) -> TxM r a
unsafeMkTxM \r
r -> r -> TxM r b -> IO b
forall r a. r -> TxM r a -> IO a
unsafeRunTxM r
r do
    a
a <- TxM r a
forall a r. TxEnv a r => TxM r a
askTxEnv
    IO b -> TxM r b
forall a r. IO a -> TxM r a
unsafeRunIOInTxM (IO b -> TxM r b) -> IO b -> TxM r b
forall a b. (a -> b) -> a -> b
$ a -> IO b
f a
a

-- | The 'TxM' monad discourages performing arbitrary 'IO' within a
-- transaction, so this instance generates a type error when client code tries
-- to call 'liftIO'.
--
-- @since 0.1.0.0
instance
  ( TypeError
      ('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")
  ) => MonadIO (TxM r)
  where
  liftIO :: IO a -> TxM r a
liftIO = IO a -> TxM r a
forall a. HasCallStack => a
undefined

-- | Run a 'TxM' to 'IO' given the database runtime environment @r@.
-- Use of this function outside of test suites should be rare.
--
-- @since 0.2.0.0
unsafeRunTxM :: r -> TxM r a -> IO a
unsafeRunTxM :: r -> TxM r a -> IO a
unsafeRunTxM r
r TxM r a
x = ReaderT r IO a -> r -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TxM r a -> ReaderT r IO a
forall r a. TxM r a -> ReaderT r IO a
unsafeUnTxM TxM r a
x) r
r

-- | Run a 'TxM' action in 'IO' via the provided runner function. Use this
-- function with care - arbitrary 'IO' should only be run within a transaction
-- when truly necessary.
--
-- @since 0.2.0.0
unsafeWithRunInIOTxM :: ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b
unsafeWithRunInIOTxM :: ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b
unsafeWithRunInIOTxM (forall a. TxM r a -> IO a) -> IO b
inner = (r -> IO b) -> TxM r b
forall r a. (r -> IO a) -> TxM r a
unsafeMkTxM \r
r -> (forall a. TxM r a -> IO a) -> IO b
inner (r -> TxM r a -> IO a
forall r a. r -> TxM r a -> IO a
unsafeRunTxM r
r)

-- | A type class for specifying how to acquire an environment value
-- to be used for running an implementation of a database library.
-- For example, your database library will likely require some sort of
-- connection value to discharge its effects; in this case, you'd want to
-- define an instance of @TxEnv MyDBEnv Connection@ and use @TxM MyDBEnv@
-- as your monad for executing transactions.
--
-- Note that implementations should take care and ensure that multiple
-- instances are compatible with one another. For example, let's say you
-- have instances for both @TxEnv E PgSimple.Connection@ and
-- @TxEnv E LibPQ.Connection@; if both of these implementations are grabbing
-- connections from a pool, you will end up with each of those database
-- libraries using different connections, and thus, would be running in
-- separate transactions!
--
-- @since 0.2.0.0
class TxEnv a r where

  -- | Acquire a value @a@ via the reader environment @r@ which assists in
  -- running a 'TxM' in a transaction.
  --
  -- @since 0.2.0.0
  lookupTxEnv :: r -> a

askTxEnv :: (TxEnv a r) => TxM r a
askTxEnv :: TxM r a
askTxEnv = (r -> IO a) -> TxM r a
forall r a. (r -> IO a) -> TxM r a
unsafeMkTxM (a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (r -> a) -> r -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
forall a r. TxEnv a r => r -> a
lookupTxEnv)

-- | Analogous to 'lookupTxEnv' but can be run in 'IO' instead of 'TxM'.
--
-- @since 0.2.0.0
unsafeLookupTxEnvIO :: (TxEnv a r) => r -> IO a
unsafeLookupTxEnvIO :: r -> IO a
unsafeLookupTxEnvIO r
r = r -> TxM r a -> IO a
forall r a. r -> TxM r a -> IO a
unsafeRunTxM r
r TxM r a
forall a r. TxEnv a r => TxM r a
askTxEnv

-- | Type family which allows for specifying several 'TxEnv' constraints as
-- a type-level list.
--
-- @since 0.2.0.0
type family TxEnvs (xs :: [*]) r :: Constraint where
  TxEnvs '[] r = ()
  TxEnvs (x ': xs) r = (TxEnv x r, TxEnvs xs r)

-- | Throw an exception.
--
-- @since 0.2.0.0
throwExceptionTx :: (Exception e) => e -> TxM r a
throwExceptionTx :: e -> TxM r a
throwExceptionTx = IO a -> TxM r a
forall a r. IO a -> TxM r a
unsafeRunIOInTxM (IO a -> TxM r a) -> (e -> IO a) -> e -> TxM r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. Exception e => e -> IO a
throwIO

-- | Catch an exception and map it to another exception type before rethrowing.
--
-- @since 0.2.0.0
mapExceptionTx
  :: (Exception e, Exception e')
  => (e -> Maybe e')
  -> TxM r a
  -> TxM r a
mapExceptionTx :: (e -> Maybe e') -> TxM r a -> TxM r a
mapExceptionTx e -> Maybe e'
mapper TxM r a
action = do
  ((forall a. TxM r a -> IO a) -> IO a) -> TxM r a
forall r b. ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b
unsafeWithRunInIOTxM \forall a. TxM r a -> IO a
run -> do
    IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (TxM r a -> IO a
forall a. TxM r a -> IO a
run TxM r a
action) \e
ex -> do
      case e -> Maybe e'
mapper e
ex of
        Maybe e'
Nothing -> e -> IO a
forall e a. Exception e => e -> IO a
throwIO e
ex
        Just e'
ex' -> e' -> IO a
forall e a. Exception e => e -> IO a
throwIO e'
ex'

-- | Unified exception type thrown from the database.
--
-- Each database backend may throw different types of exceptions.
-- As a user of @postgresql-tx@, ideally we should be able to
-- detect exceptions from the database without needing to catch
-- the database backend's exception type.
--
-- The 'errcode' field allows us to introspect the postgresql
-- @errcode@; see https://www.postgresql.org/docs/current/errcodes-appendix.html
--
-- If you need to inspect the exact exception thrown by a database
-- backend, use the 'cause' field.
data TxException = TxException
  { TxException -> Maybe String
errcode :: Maybe String
  , TxException -> SomeException
cause :: SomeException
  } deriving stock (Int -> TxException -> ShowS
[TxException] -> ShowS
TxException -> String
(Int -> TxException -> ShowS)
-> (TxException -> String)
-> ([TxException] -> ShowS)
-> Show TxException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxException] -> ShowS
$cshowList :: [TxException] -> ShowS
show :: TxException -> String
$cshow :: TxException -> String
showsPrec :: Int -> TxException -> ShowS
$cshowsPrec :: Int -> TxException -> ShowS
Show)

instance Exception TxException

-- | PostgreSQL @errcode@ for @serialization_failure@.
errcode'serialization_failure :: String
errcode'serialization_failure :: String
errcode'serialization_failure = String
"40001"

-- | PostgreSQL @errcode@ for @deadlock_detected@.
errcode'deadlock_detected :: String
errcode'deadlock_detected :: String
errcode'deadlock_detected = String
"40P01"

-- | Checks if the 'errcode' of a 'TxException' matches the supplied predicate.
-- If the 'errcode' is 'Nothing', returns 'False'.
hasErrcode :: (String -> Bool) -> TxException -> Bool
hasErrcode :: (String -> Bool) -> TxException -> Bool
hasErrcode String -> Bool
p TxException { Maybe String
errcode :: Maybe String
errcode :: TxException -> Maybe String
errcode } = (String -> Bool) -> Maybe String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
p Maybe String
errcode

-- | Useful as a predicate to indicate when to retry transactions which are
-- run at isolation level @serializable@
shouldRetryTx :: TxException -> Bool
shouldRetryTx :: TxException -> Bool
shouldRetryTx =
  (String -> Bool) -> TxException -> Bool
hasErrcode
    (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
      [ String
errcode'serialization_failure
      , String
errcode'deadlock_detected
      ])

-- | Construct a 'TxException' from an @errcode@ accessing function
-- and the 'cause' exception.
--
-- Note that this function should only be used by libraries
-- which are implementing a database backend for @postgresql-tx@.
unsafeMkTxException
  :: (Exception e) => (e -> Maybe String) -> e -> TxException
unsafeMkTxException :: (e -> Maybe String) -> e -> TxException
unsafeMkTxException e -> Maybe String
f e
e =
  TxException :: Maybe String -> SomeException -> TxException
TxException
    { errcode :: Maybe String
errcode = e -> Maybe String
f e
e
    , cause :: SomeException
cause = e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e
    }

-- $disclaimer
--
-- Changes to this module will not be reflected in the library's version
-- updates.