git.iko.soy/typeable/postgresql-simple
on master help sign in
Merge pull request #34 from joeyadams/withTransactionSerializable
ef1c64fLeon P Smith
postgresql-simple.cabal+1
compare with master
unifiedsplit
@@ -78,6 +78,7 @@ test-suite test
78 Bytea
78 Bytea
79 ExecuteMany
79 ExecuteMany
80 Notify
80 Notify
81+ Serializable
81 Time
82 Time
82
83
83 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
84 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
src/Database/PostgreSQL/Simple.hs+53−1
@@ -97,6 +97,7 @@ module Database.PostgreSQL.Simple
97-- , Base.insertID
97-- , Base.insertID
98 -- * Transaction handling
98 -- * Transaction handling
99 , withTransaction
99 , withTransaction
100+ , withTransactionSerializable
100 , TransactionMode(..)
101 , TransactionMode(..)
101 , IsolationLevel(..)
102 , IsolationLevel(..)
102 , ReadWriteMode(..)
103 , ReadWriteMode(..)
@@ -105,6 +106,7 @@ module Database.PostgreSQL.Simple
105 , defaultReadWriteMode
106 , defaultReadWriteMode
106 , withTransactionLevel
107 , withTransactionLevel
107 , withTransactionMode
108 , withTransactionMode
109+ , withTransactionModeRetry
108-- , Base.autocommit
110-- , Base.autocommit
109 , begin
111 , begin
110 , beginLevel
112 , beginLevel
@@ -122,7 +124,8 @@ import Blaze.ByteString.Builder.Char8 (fromChar)
122import Control.Applicative ((<$>), pure)
124import Control.Applicative ((<$>), pure)
123import Control.Concurrent.MVar
125import Control.Concurrent.MVar
124import Control.Exception
126import Control.Exception
125− ( Exception, onException, throw, throwIO, finally )
127+ ( Exception, onException, throw, throwIO, finally
128+ , try, SomeException, fromException )
126import Control.Monad (foldM)
129import Control.Monad (foldM)
127import Data.ByteString (ByteString)
130import Data.ByteString (ByteString)
128import Data.Int (Int64)
131import Data.Int (Int64)
@@ -643,6 +646,24 @@ defaultReadWriteMode = DefaultReadWriteMode
643withTransaction :: Connection -> IO a -> IO a
646withTransaction :: Connection -> IO a -> IO a
644withTransaction = withTransactionMode defaultTransactionMode
647withTransaction = withTransactionMode defaultTransactionMode
645
648
649+-- | Execute an action inside of a 'Serializable' transaction. If a
650+-- serialization failure occurs, roll back the transaction and try again.
651+-- Be warned that this may execute the IO action multiple times.
652+--
653+-- A 'Serializable' transaction creates the illusion that your program has
654+-- exclusive access to the database. This means that, even in a concurrent
655+-- setting, you can perform queries in sequence without having to worry about
656+-- what might happen between one statement and the next.
657+--
658+-- Think of it as STM, but without @retry@.
659+withTransactionSerializable :: Connection -> IO a -> IO a
660+withTransactionSerializable =
661+ withTransactionModeRetry
662+ TransactionMode
663+ { isolationLevel = Serializable
664+ , readWriteMode = ReadWrite
665+ }
666+
646-- | Execute an action inside a SQL transaction with a given isolation level.
667-- | Execute an action inside a SQL transaction with a given isolation level.
647withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
668withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
648withTransactionLevel lvl
669withTransactionLevel lvl
@@ -657,6 +678,37 @@ withTransactionMode mode conn act =
657 commit conn
678 commit conn
658 return r
679 return r
659
680
681+-- | Like 'withTransactionMode', but if a 'SqlError' arises whose 'sqlState' is
682+-- @\"40001\"@ (@serialization_failure@), this will issue a @ROLLBACK@, then
683+-- try the action again. If any other exception arises, this will issue a
684+-- @ROLLBACK@, but will propagate the exception instead of retrying.
685+--
686+-- This is used to implement 'withTransactionSerializable'.
687+withTransactionModeRetry :: TransactionMode -> Connection -> IO a -> IO a
688+withTransactionModeRetry mode conn act =
689+ mask $ \restore ->
690+ retryLoop $ try $ do
691+ a <- restore act
692+ commit conn
693+ return a
694+ where
695+ retryLoop :: IO (Either SomeException a) -> IO a
696+ retryLoop act' = do
697+ beginMode mode conn
698+ r <- act'
699+ case r of
700+ Left e -> do
701+ rollback conn
702+ case fromException e of
703+ Just SqlError{..} | sqlState == serialization_failure
704+ -> retryLoop act'
705+ _ -> throwIO e
706+ Right a ->
707+ return a
708+
709+ -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
710+ serialization_failure = "40001"
711+
660-- | Rollback a transaction.
712-- | Rollback a transaction.
661rollback :: Connection -> IO ()
713rollback :: Connection -> IO ()
662rollback conn = execute_ conn "ABORT" >> return ()
714rollback conn = execute_ conn "ABORT" >> return ()
test/Main.hs+2
@@ -7,6 +7,7 @@ import System.IO
7import Bytea
7import Bytea
8import ExecuteMany
8import ExecuteMany
9import Notify
9import Notify
10+import Serializable
10import Time
11import Time
11
12
12tests :: [TestEnv -> Test]
13tests :: [TestEnv -> Test]
@@ -15,6 +16,7 @@ tests =
15 , TestLabel "Notify" . testNotify
16 , TestLabel "Notify" . testNotify
16 , TestLabel "ExecuteMany" . testExecuteMany
17 , TestLabel "ExecuteMany" . testExecuteMany
17 , TestLabel "Time" . testTime
18 , TestLabel "Time" . testTime
19+ , TestLabel "Serializable" . testSerializable
18 ]
20 ]
19
21
20-- | Action for connecting to the database that will be used for testing.
22-- | Action for connecting to the database that will be used for testing.
test/Serializable.hsnew file+69
@@ -0,0 +1,69 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+module Serializable (testSerializable) where
3+
4+import Common
5+import Control.Concurrent
6+import Control.Exception as E
7+import Data.IORef
8+
9+initCounter :: Connection -> IO ()
10+initCounter conn = do
11+ 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\
12+ \ CREATE TABLE testSerializableCounter (n INT)"
13+ 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)"
14+ return ()
15+
16+getCounter :: Connection -> IO Int
17+getCounter conn = do
18+ [Only n] <- query_ conn "SELECT n FROM testSerializableCounter"
19+ return n
20+
21+putCounter :: Connection -> Int -> IO ()
22+putCounter conn n = do
23+ 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
24+ return ()
25+
26+testSerializable :: TestEnv -> Test
27+testSerializable TestEnv{..} =
28+ TestCase $
29+ withConn $ \conn2 -> do
30+ initCounter conn
31+
32+ attemptCounter <- newIORef (0 :: Int)
33+ readyToBother <- newEmptyMVar
34+ bothered <- newEmptyMVar
35+ finished <- newEmptyMVar
36+
37+ _ <- forkIO $ do
38+ withTransactionSerializable conn2 $ do
39+ modifyIORef attemptCounter (+1)
40+ n <- getCounter conn2
41+ True <- tryPutMVar readyToBother ()
42+ readMVar bothered
43+ putCounter conn2 (n+1)
44+ putMVar finished ()
45+
46+ takeMVar readyToBother
47+ withTransactionSerializable conn $ do
48+ n <- getCounter conn
49+ putCounter conn (n+1)
50+ True <- tryPutMVar bothered ()
51+
52+ takeMVar finished
53+
54+ ac <- readIORef attemptCounter
55+ assertEqual "attemptCounter" 2 ac
56+
57+ ok <- E.catch (do withTransactionSerializable conn (fail "Whoops")
58+ return False)
59+ (\(_ :: IOException) -> return True)
60+ assertBool "Exceptions (besides serialization failure) should be\
61+ \ propagated through withTransactionSerializable"
62+ ok
63+
64+ -- Make sure transaction isn't dangling
65+ 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345"
66+ 0 <- execute_ conn "ROLLBACK"
67+ -- This prints "NOTICE: there is no transaction in progress"
68+ [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter"
69+ return ()