{-# LANGUAGE
DataKinds
, FlexibleContexts
, LambdaCase
, OverloadedStrings
, TypeInType
#-}
module Squeal.PostgreSQL.Session.Transaction.Unsafe
(
transactionally
, transactionally_
, transactionallyRetry
, transactionallyRetry_
, ephemerally
, ephemerally_
, begin
, commit
, rollback
, withSavepoint
, TransactionMode (..)
, defaultMode
, retryMode
, longRunningMode
, IsolationLevel (..)
, AccessMode (..)
, DeferrableMode (..)
) where
import Control.Monad
import Control.Monad.Catch
import Data.ByteString
import Data.Either
import Squeal.PostgreSQL.Manipulation
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Session.Exception
import Squeal.PostgreSQL.Session.Monad
transactionally
:: (MonadMask tx, MonadPQ db tx)
=> TransactionMode
-> tx x
-> tx x
transactionally :: TransactionMode -> tx x -> tx x
transactionally TransactionMode
mode tx x
tx = ((forall a. tx a -> tx a) -> tx x) -> tx x
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. tx a -> tx a) -> tx x) -> tx x)
-> ((forall a. tx a -> tx a) -> tx x) -> tx x
forall a b. (a -> b) -> a -> b
$ \forall a. tx a -> tx a
restore -> do
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> tx ())
-> Manipulation '[] db '[] '[] -> tx ()
forall a b. (a -> b) -> a -> b
$ TransactionMode -> Manipulation_ db () ()
forall (db :: SchemasType).
TransactionMode -> Manipulation_ db () ()
begin TransactionMode
mode
x
result <- tx x -> tx x
forall a. tx a -> tx a
restore tx x
tx tx x -> tx () -> tx x
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
commit
x -> tx x
forall (m :: * -> *) a. Monad m => a -> m a
return x
result
transactionally_
:: (MonadMask tx, MonadPQ db tx)
=> tx x
-> tx x
transactionally_ :: tx x -> tx x
transactionally_ = TransactionMode -> tx x -> tx x
forall (tx :: * -> *) (db :: SchemasType) x.
(MonadMask tx, MonadPQ db tx) =>
TransactionMode -> tx x -> tx x
transactionally TransactionMode
defaultMode
transactionallyRetry
:: (MonadMask tx, MonadPQ db tx)
=> TransactionMode
-> tx x
-> tx x
transactionallyRetry :: TransactionMode -> tx x -> tx x
transactionallyRetry TransactionMode
mode tx x
tx = ((forall a. tx a -> tx a) -> tx x) -> tx x
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. tx a -> tx a) -> tx x) -> tx x)
-> ((forall a. tx a -> tx a) -> tx x) -> tx x
forall a b. (a -> b) -> a -> b
$ \forall a. tx a -> tx a
restore ->
tx (Either SquealException x) -> tx x
forall (db :: SchemasType) (m :: * -> *) b.
(MonadPQ db m, MonadThrow m) =>
m (Either SquealException b) -> m b
loop (tx (Either SquealException x) -> tx x)
-> (tx x -> tx (Either SquealException x)) -> tx x -> tx x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tx x -> tx (Either SquealException x)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (tx x -> tx x) -> tx x -> tx x
forall a b. (a -> b) -> a -> b
$ do
x
x <- tx x -> tx x
forall a. tx a -> tx a
restore tx x
tx
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
commit
x -> tx x
forall (m :: * -> *) a. Monad m => a -> m a
return x
x
where
loop :: m (Either SquealException b) -> m b
loop m (Either SquealException b)
attempt = do
Manipulation '[] db '[] '[] -> m ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> m ())
-> Manipulation '[] db '[] '[] -> m ()
forall a b. (a -> b) -> a -> b
$ TransactionMode -> Manipulation_ db () ()
forall (db :: SchemasType).
TransactionMode -> Manipulation_ db () ()
begin TransactionMode
mode
m (Either SquealException b)
attempt m (Either SquealException b)
-> (Either SquealException b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SerializationFailure ByteString
_) -> do
Manipulation '[] db '[] '[] -> m ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback
m (Either SquealException b) -> m b
loop m (Either SquealException b)
attempt
Left (DeadlockDetected ByteString
_) -> do
Manipulation '[] db '[] '[] -> m ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback
m (Either SquealException b) -> m b
loop m (Either SquealException b)
attempt
Left SquealException
err -> do
Manipulation '[] db '[] '[] -> m ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback
SquealException -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SquealException
err
Right b
x -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
transactionallyRetry_
:: (MonadMask tx, MonadPQ db tx)
=> tx x
-> tx x
transactionallyRetry_ :: tx x -> tx x
transactionallyRetry_ = TransactionMode -> tx x -> tx x
forall (tx :: * -> *) (db :: SchemasType) x.
(MonadMask tx, MonadPQ db tx) =>
TransactionMode -> tx x -> tx x
transactionallyRetry TransactionMode
retryMode
ephemerally
:: (MonadMask tx, MonadPQ db tx)
=> TransactionMode
-> tx x
-> tx x
ephemerally :: TransactionMode -> tx x -> tx x
ephemerally TransactionMode
mode tx x
tx = ((forall a. tx a -> tx a) -> tx x) -> tx x
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. tx a -> tx a) -> tx x) -> tx x)
-> ((forall a. tx a -> tx a) -> tx x) -> tx x
forall a b. (a -> b) -> a -> b
$ \forall a. tx a -> tx a
restore -> do
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> tx ())
-> Manipulation '[] db '[] '[] -> tx ()
forall a b. (a -> b) -> a -> b
$ TransactionMode -> Manipulation_ db () ()
forall (db :: SchemasType).
TransactionMode -> Manipulation_ db () ()
begin TransactionMode
mode
x
result <- tx x -> tx x
forall a. tx a -> tx a
restore tx x
tx tx x -> tx () -> tx x
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` (Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback)
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ Manipulation '[] db '[] '[]
forall (db :: SchemasType). Manipulation_ db () ()
rollback
x -> tx x
forall (m :: * -> *) a. Monad m => a -> m a
return x
result
ephemerally_
:: (MonadMask tx, MonadPQ db tx)
=> tx x
-> tx x
ephemerally_ :: tx x -> tx x
ephemerally_ = TransactionMode -> tx x -> tx x
forall (tx :: * -> *) (db :: SchemasType) x.
(MonadMask tx, MonadPQ db tx) =>
TransactionMode -> tx x -> tx x
ephemerally TransactionMode
defaultMode
begin :: TransactionMode -> Manipulation_ db () ()
begin :: TransactionMode -> Manipulation_ db () ()
begin TransactionMode
mode = ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation (ByteString -> Manipulation '[] db '[] '[])
-> ByteString -> Manipulation '[] db '[] '[]
forall a b. (a -> b) -> a -> b
$ ByteString
"BEGIN" ByteString -> ByteString -> ByteString
<+> TransactionMode -> ByteString
forall sql. RenderSQL sql => sql -> ByteString
renderSQL TransactionMode
mode
commit :: Manipulation_ db () ()
commit :: Manipulation_ db () ()
commit = ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation ByteString
"COMMIT"
rollback :: Manipulation_ db () ()
rollback :: Manipulation_ db () ()
rollback = ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation ByteString
"ROLLBACK"
withSavepoint
:: MonadPQ db tx
=> ByteString
-> tx (Either e x)
-> tx (Either e x)
withSavepoint :: ByteString -> tx (Either e x) -> tx (Either e x)
withSavepoint ByteString
savepoint tx (Either e x)
tx = do
let svpt :: ByteString
svpt = ByteString
"SAVEPOINT" ByteString -> ByteString -> ByteString
<+> ByteString
savepoint
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> tx ())
-> Manipulation '[] db '[] '[] -> tx ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation (ByteString -> Manipulation '[] db '[] '[])
-> ByteString -> Manipulation '[] db '[] '[]
forall a b. (a -> b) -> a -> b
$ ByteString
svpt
Either e x
e_x <- tx (Either e x)
tx
Bool -> tx () -> tx ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either e x -> Bool
forall a b. Either a b -> Bool
isLeft Either e x
e_x) (tx () -> tx ()) -> tx () -> tx ()
forall a b. (a -> b) -> a -> b
$
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> tx ())
-> Manipulation '[] db '[] '[] -> tx ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation (ByteString -> Manipulation '[] db '[] '[])
-> ByteString -> Manipulation '[] db '[] '[]
forall a b. (a -> b) -> a -> b
$ ByteString
"ROLLBACK TO" ByteString -> ByteString -> ByteString
<+> ByteString
svpt
Manipulation '[] db '[] '[] -> tx ()
forall (db :: SchemasType) (pq :: * -> *).
MonadPQ db pq =>
Manipulation '[] db '[] '[] -> pq ()
manipulate_ (Manipulation '[] db '[] '[] -> tx ())
-> Manipulation '[] db '[] '[] -> tx ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Manipulation '[] db '[] '[]
forall (with :: FromType) (db :: SchemasType)
(params :: [NullType]) (columns :: RowType).
ByteString -> Manipulation with db params columns
UnsafeManipulation (ByteString -> Manipulation '[] db '[] '[])
-> ByteString -> Manipulation '[] db '[] '[]
forall a b. (a -> b) -> a -> b
$ ByteString
"RELEASE" ByteString -> ByteString -> ByteString
<+> ByteString
svpt
Either e x -> tx (Either e x)
forall (m :: * -> *) a. Monad m => a -> m a
return Either e x
e_x
data TransactionMode = TransactionMode
{ TransactionMode -> IsolationLevel
isolationLevel :: IsolationLevel
, TransactionMode -> AccessMode
accessMode :: AccessMode
, TransactionMode -> DeferrableMode
deferrableMode :: DeferrableMode
} deriving (Int -> TransactionMode -> ShowS
[TransactionMode] -> ShowS
TransactionMode -> String
(Int -> TransactionMode -> ShowS)
-> (TransactionMode -> String)
-> ([TransactionMode] -> ShowS)
-> Show TransactionMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionMode] -> ShowS
$cshowList :: [TransactionMode] -> ShowS
show :: TransactionMode -> String
$cshow :: TransactionMode -> String
showsPrec :: Int -> TransactionMode -> ShowS
$cshowsPrec :: Int -> TransactionMode -> ShowS
Show, TransactionMode -> TransactionMode -> Bool
(TransactionMode -> TransactionMode -> Bool)
-> (TransactionMode -> TransactionMode -> Bool)
-> Eq TransactionMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionMode -> TransactionMode -> Bool
$c/= :: TransactionMode -> TransactionMode -> Bool
== :: TransactionMode -> TransactionMode -> Bool
$c== :: TransactionMode -> TransactionMode -> Bool
Eq)
defaultMode :: TransactionMode
defaultMode :: TransactionMode
defaultMode = IsolationLevel -> AccessMode -> DeferrableMode -> TransactionMode
TransactionMode IsolationLevel
ReadCommitted AccessMode
ReadWrite DeferrableMode
NotDeferrable
retryMode :: TransactionMode
retryMode :: TransactionMode
retryMode = IsolationLevel -> AccessMode -> DeferrableMode -> TransactionMode
TransactionMode IsolationLevel
Serializable AccessMode
ReadWrite DeferrableMode
NotDeferrable
longRunningMode :: TransactionMode
longRunningMode :: TransactionMode
longRunningMode = IsolationLevel -> AccessMode -> DeferrableMode -> TransactionMode
TransactionMode IsolationLevel
Serializable AccessMode
ReadOnly DeferrableMode
Deferrable
instance RenderSQL TransactionMode where
renderSQL :: TransactionMode -> ByteString
renderSQL TransactionMode
mode =
ByteString
"ISOLATION LEVEL"
ByteString -> ByteString -> ByteString
<+> IsolationLevel -> ByteString
forall sql. RenderSQL sql => sql -> ByteString
renderSQL (TransactionMode -> IsolationLevel
isolationLevel TransactionMode
mode)
ByteString -> ByteString -> ByteString
<+> AccessMode -> ByteString
forall sql. RenderSQL sql => sql -> ByteString
renderSQL (TransactionMode -> AccessMode
accessMode TransactionMode
mode)
ByteString -> ByteString -> ByteString
<+> DeferrableMode -> ByteString
forall sql. RenderSQL sql => sql -> ByteString
renderSQL (TransactionMode -> DeferrableMode
deferrableMode TransactionMode
mode)
data IsolationLevel
= Serializable
| RepeatableRead
| ReadCommitted
| ReadUncommitted
deriving (Int -> IsolationLevel -> ShowS
[IsolationLevel] -> ShowS
IsolationLevel -> String
(Int -> IsolationLevel -> ShowS)
-> (IsolationLevel -> String)
-> ([IsolationLevel] -> ShowS)
-> Show IsolationLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsolationLevel] -> ShowS
$cshowList :: [IsolationLevel] -> ShowS
show :: IsolationLevel -> String
$cshow :: IsolationLevel -> String
showsPrec :: Int -> IsolationLevel -> ShowS
$cshowsPrec :: Int -> IsolationLevel -> ShowS
Show, IsolationLevel -> IsolationLevel -> Bool
(IsolationLevel -> IsolationLevel -> Bool)
-> (IsolationLevel -> IsolationLevel -> Bool) -> Eq IsolationLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsolationLevel -> IsolationLevel -> Bool
$c/= :: IsolationLevel -> IsolationLevel -> Bool
== :: IsolationLevel -> IsolationLevel -> Bool
$c== :: IsolationLevel -> IsolationLevel -> Bool
Eq)
instance RenderSQL IsolationLevel where
renderSQL :: IsolationLevel -> ByteString
renderSQL = \case
IsolationLevel
Serializable -> ByteString
"SERIALIZABLE"
IsolationLevel
ReadCommitted -> ByteString
"READ COMMITTED"
IsolationLevel
ReadUncommitted -> ByteString
"READ UNCOMMITTED"
IsolationLevel
RepeatableRead -> ByteString
"REPEATABLE READ"
data AccessMode
= ReadWrite
| ReadOnly
deriving (Int -> AccessMode -> ShowS
[AccessMode] -> ShowS
AccessMode -> String
(Int -> AccessMode -> ShowS)
-> (AccessMode -> String)
-> ([AccessMode] -> ShowS)
-> Show AccessMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccessMode] -> ShowS
$cshowList :: [AccessMode] -> ShowS
show :: AccessMode -> String
$cshow :: AccessMode -> String
showsPrec :: Int -> AccessMode -> ShowS
$cshowsPrec :: Int -> AccessMode -> ShowS
Show, AccessMode -> AccessMode -> Bool
(AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> Bool) -> Eq AccessMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccessMode -> AccessMode -> Bool
$c/= :: AccessMode -> AccessMode -> Bool
== :: AccessMode -> AccessMode -> Bool
$c== :: AccessMode -> AccessMode -> Bool
Eq)
instance RenderSQL AccessMode where
renderSQL :: AccessMode -> ByteString
renderSQL = \case
AccessMode
ReadWrite -> ByteString
"READ WRITE"
AccessMode
ReadOnly -> ByteString
"READ ONLY"
data DeferrableMode
= Deferrable
| NotDeferrable
deriving (Int -> DeferrableMode -> ShowS
[DeferrableMode] -> ShowS
DeferrableMode -> String
(Int -> DeferrableMode -> ShowS)
-> (DeferrableMode -> String)
-> ([DeferrableMode] -> ShowS)
-> Show DeferrableMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeferrableMode] -> ShowS
$cshowList :: [DeferrableMode] -> ShowS
show :: DeferrableMode -> String
$cshow :: DeferrableMode -> String
showsPrec :: Int -> DeferrableMode -> ShowS
$cshowsPrec :: Int -> DeferrableMode -> ShowS
Show, DeferrableMode -> DeferrableMode -> Bool
(DeferrableMode -> DeferrableMode -> Bool)
-> (DeferrableMode -> DeferrableMode -> Bool) -> Eq DeferrableMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeferrableMode -> DeferrableMode -> Bool
$c/= :: DeferrableMode -> DeferrableMode -> Bool
== :: DeferrableMode -> DeferrableMode -> Bool
$c== :: DeferrableMode -> DeferrableMode -> Bool
Eq)
instance RenderSQL DeferrableMode where
renderSQL :: DeferrableMode -> ByteString
renderSQL = \case
DeferrableMode
Deferrable -> ByteString
"DEFERRABLE"
DeferrableMode
NotDeferrable -> ByteString
"NOT DEFERRABLE"