{-# 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
(
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)
newtype TxM r a = UnsafeTxM
{
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)
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
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
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
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
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
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)
class TxEnv a r where
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)
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 TxEnvs (xs :: [*]) r :: Constraint where
TxEnvs '[] r = ()
TxEnvs (x ': xs) r = (TxEnv x r, TxEnvs xs r)
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
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'
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
errcode'serialization_failure :: String
errcode'serialization_failure :: String
errcode'serialization_failure = String
"40001"
errcode'deadlock_detected :: String
errcode'deadlock_detected :: String
errcode'deadlock_detected = String
"40P01"
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
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
])
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
}