@@ -8,7 +8,6 @@ module Database.PostgreSQL.Simple.Transaction
88 , withTransactionMode
99 , withTransactionModeRetry
1010 , withTransactionSerializable
11− , isSerializationError
1211 , TransactionMode(..)
1312 , IsolationLevel(..)
1413 , ReadWriteMode(..)
@@ -21,13 +20,27 @@ module Database.PostgreSQL.Simple.Transaction
2120 , beginMode
2221 , commit
2322 , rollback
23+
24+ -- * Savepoint
25+ , withSavepoint
26+ , Savepoint
27+ , newSavepoint
28+ , releaseSavepoint
29+ , rollbackToSavepoint
30+ , rollbackToAndReleaseSavepoint
31+
32+ -- * Error predicates
33+ , isSerializationError
34+ , isNoActiveTransactionError
35+ , isFailedTransactionError
2436 ) where
2537
26−import Control.Exception hiding (mask)
38+import qualified Control.Exception as E
39+import Data.ByteString (ByteString)
2740import qualified Data.ByteString as B
2841import Database.PostgreSQL.Simple.Internal
2942import Database.PostgreSQL.Simple.Types
30−import Database.PostgreSQL.Simple.Compat(mask)
43+import Database.PostgreSQL.Simple.Compat (mask, (<>))
3144
3245
3346-- | Of the four isolation levels defined by the SQL standard,
@@ -85,6 +98,8 @@ defaultReadWriteMode = DefaultReadWriteMode
8598-- If the action throws /any/ kind of exception (not just a
8699-- PostgreSQL-related exception), the transaction will be rolled back using
87100-- 'rollback', then the exception will be rethrown.
101+--
102+-- For nesting transactions, see 'withSavepoint'.
88103withTransaction :: Connection -> IO a -> IO a
89104withTransaction = withTransactionMode defaultTransactionMode
90105
@@ -107,17 +122,6 @@ withTransactionSerializable =
107122 }
108123 isSerializationError
109124
110−
111−isSerializationError :: SqlError -> Bool
112−isSerializationError exception =
113− case exception of
114− SqlError{..} | sqlState == serialization_failure
115− -> True
116− _ -> False
117− where
118− -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
119− serialization_failure = "40001"
120−
121125-- | Execute an action inside a SQL transaction with a given isolation level.
122126withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
123127withTransactionLevel lvl
@@ -128,7 +132,7 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
128132withTransactionMode mode conn act =
129133 mask $ \restore -> do
130134 beginMode mode conn
131− r <- restore act `onException` rollback conn
135+ r <- restore act `E.onException` rollback conn
132136 commit conn
133137 return r
134138
@@ -142,21 +146,21 @@ withTransactionMode mode conn act =
142146withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
143147withTransactionModeRetry mode shouldRetry conn act =
144148 mask $ \restore ->
145− retryLoop $ try $ do
149+ retryLoop $ E.try $ do
146150 a <- restore act
147151 commit conn
148152 return a
149153 where
150− retryLoop :: IO (Either SomeException a) -> IO a
154+ retryLoop :: IO (Either E.SomeException a) -> IO a
151155 retryLoop act' = do
152156 beginMode mode conn
153157 r <- act'
154158 case r of
155159 Left e -> do
156160 rollback conn
157− case fmap shouldRetry (fromException e) of
161+ case fmap shouldRetry (E.fromException e) of
158162 Just True -> retryLoop act'
159− _ -> throwIO e
163+ _ -> E.throwIO e
160164 Right a ->
161165 return a
162166
@@ -191,3 +195,69 @@ beginMode mode conn = do
191195 DefaultReadWriteMode -> ""
192196 ReadWrite -> " READ WRITE"
193197 ReadOnly -> " READ ONLY"
198+
199+------------------------------------------------------------------------
200+-- Savepoint
201+
202+-- | Create a savepoint, and roll back to it if an error occurs. This may only
203+-- be used inside of a transaction, and provides a sort of
204+-- \"nested transaction\".
205+--
206+-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>
207+withSavepoint :: Connection -> IO a -> IO a
208+withSavepoint conn body =
209+ mask $ \restore -> do
210+ sp <- newSavepoint conn
211+ r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp
212+ releaseSavepoint conn sp `E.catch` \err ->
213+ if isFailedTransactionError err
214+ then rollbackToAndReleaseSavepoint conn sp
215+ else E.throwIO err
216+ return r
217+
218+-- | Create a new savepoint. This may only be used inside of a transaction.
219+newSavepoint :: Connection -> IO Savepoint
220+newSavepoint conn = do
221+ name <- newTempName conn
222+ _ <- execute_ conn ("SAVEPOINT " <> name)
223+ return (Savepoint name)
224+
225+-- | Destroy a savepoint, but retain its effects.
226+--
227+-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if
228+-- the transaction is aborted due to an error. 'commit' would merely warn and
229+-- roll back.
230+releaseSavepoint :: Connection -> Savepoint -> IO ()
231+releaseSavepoint conn (Savepoint name) =
232+ execute_ conn ("RELEASE SAVEPOINT " <> name) >> return ()
233+
234+-- | Roll back to a savepoint. This will not release the savepoint.
235+rollbackToSavepoint :: Connection -> Savepoint -> IO ()
236+rollbackToSavepoint conn (Savepoint name) =
237+ execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return ()
238+
239+-- | Roll back to a savepoint and release it. This is like calling
240+-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a
241+-- round trip to the database server.
242+rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO ()
243+rollbackToAndReleaseSavepoint conn (Savepoint name) =
244+ execute_ conn sql >> return ()
245+ where
246+ sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name
247+
248+------------------------------------------------------------------------
249+-- Error predicates
250+--
251+-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
252+
253+isSerializationError :: SqlError -> Bool
254+isSerializationError = isSqlState "40001"
255+
256+isNoActiveTransactionError :: SqlError -> Bool
257+isNoActiveTransactionError = isSqlState "25P01"
258+
259+isFailedTransactionError :: SqlError -> Bool
260+isFailedTransactionError = isSqlState "25P02"
261+
262+isSqlState :: ByteString -> SqlError -> Bool
263+isSqlState s SqlError{..} = sqlState == s