@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL.Transaction
33Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -20,11 +20,10 @@ module Squeal.PostgreSQL.Transaction
2020 ( -- * Transaction
2121 transactionally
2222 , transactionally_
23+ , transactionallyRetry
2324 , begin
2425 , commit
2526 , rollback
26− , transactionallySchema
27− , transactionallySchema_
2827 -- * Transaction Mode
2928 , TransactionMode (..)
3029 , defaultMode
@@ -34,68 +33,76 @@ module Squeal.PostgreSQL.Transaction
3433 , DeferrableMode (..)
3534 ) where
3635
37−import Generics.SOP
38−import UnliftIO (MonadUnliftIO, liftIO, mask, onException)
39−
40−import qualified Database.PostgreSQL.LibPQ as LibPQ
36+import Control.Monad
37+import UnliftIO
4138
4239import Squeal.PostgreSQL.Manipulation
4340import Squeal.PostgreSQL.Render
4441import Squeal.PostgreSQL.PQ
45−import Squeal.PostgreSQL.Schema
4642
47−-- | Run a schema invariant computation `transactionally`.
43+{- | Run a computation `transactionally`;
44+first `begin`,
45+then run the computation,
46+`onException` `rollback` and rethrow the exception,
47+otherwise `commit` and `return` the result.
48+-}
4849transactionally
4950 :: (MonadUnliftIO tx, MonadPQ schemas tx)
5051 => TransactionMode
5152 -> tx x -- ^ run inside a transaction
5253 -> tx x
5354transactionally mode tx = mask $ \restore -> do
54− _ <- begin mode
55+ begin mode
5556 result <- restore tx `onException` rollback
56− _ <- commit
57+ commit
5758 return result
5859
59−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
60+-- | Run a computation `transactionally_`, in `defaultMode`.
6061transactionally_
6162 :: (MonadUnliftIO tx, MonadPQ schemas tx)
6263 => tx x -- ^ run inside a transaction
6364 -> tx x
6465transactionally_ = transactionally defaultMode
6566
67+{- |
68+`transactionallyRetry` a computation;
69+
70+* first `begin`,
71+* then `try` the computation,
72+ - if it raises a serialization failure then `rollback` and restart the transaction,
73+ - if it raises any other exception then `rollback` and rethrow the exception,
74+ - otherwise `commit` and `return` the result.
75+-}
76+transactionallyRetry
77+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
78+ => TransactionMode
79+ -> tx x -- ^ run inside a transaction
80+ -> tx x
81+transactionallyRetry mode tx = mask $ \restore ->
82+ loop . try $ do
83+ x <- restore tx
84+ commit
85+ return x
86+ where
87+ loop attempt = do
88+ begin mode
89+ attempt >>= \case
90+ Left (PQException _ (Just "40001") _) -> rollback >> loop attempt
91+ Left err -> rollback >> throwIO err
92+ Right x -> return x
93+
6694-- | @BEGIN@ a transaction.
67−begin :: MonadPQ schemas tx => TransactionMode -> tx (K Result ('[] :: RowType))
68−begin mode = manipulate . UnsafeManipulation $
95+begin :: MonadPQ schemas tx => TransactionMode -> tx ()
96+begin mode = void . manipulate . UnsafeManipulation $
6997 "BEGIN" <+> renderSQL mode <> ";"
7098
71−-- | @COMMIT@ a schema invariant transaction.
72−commit :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
73−commit = manipulate $ UnsafeManipulation "COMMIT;"
99+-- | @COMMIT@ a transaction.
100+commit :: MonadPQ schemas tx => tx ()
101+commit = void . manipulate $ UnsafeManipulation "COMMIT;"
74102
75−-- | @ROLLBACK@ a schema invariant transaction.
76−rollback :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
77−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
78−
79−-- | Run a schema changing computation `transactionallySchema`.
80−transactionallySchema
81− :: MonadUnliftIO io
82− => TransactionMode
83− -> PQ schemas0 schemas1 io x
84− -> PQ schemas0 schemas1 io x
85−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
86− _ <- liftIO . LibPQ.exec (unK conn) $
87− "BEGIN" <+> renderSQL mode <> ";"
88− x <- restore (unPQ u conn)
89− `onException` (liftIO (LibPQ.exec (unK conn) "ROLLBACK"))
90− _ <- liftIO $ LibPQ.exec (unK conn) "COMMIT"
91− return x
92−
93−-- | Run a schema changing computation `transactionallySchema_` in `defaultMode`.
94−transactionallySchema_
95− :: MonadUnliftIO io
96− => PQ schemas0 schemas1 io x
97− -> PQ schemas0 schemas1 io x
98−transactionallySchema_ = transactionallySchema defaultMode
103+-- | @ROLLBACK@ a transaction.
104+rollback :: MonadPQ schemas tx => tx ()
105+rollback = void . manipulate $ UnsafeManipulation "ROLLBACK;"
99106
100107-- | The available transaction characteristics are the transaction `IsolationLevel`,
101108-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -108,7 +115,7 @@ data TransactionMode = TransactionMode
108115-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
109116-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
110117defaultMode :: TransactionMode
111−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
118+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
112119
113120-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
114121-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.