git.iko.soy/typeable/postgresql-simple
on master help sign in
Add withTransactionSerializable
8342dcbJoey Adams
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+48−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(..)
@@ -122,7 +123,8 @@ import Blaze.ByteString.Builder.Char8 (fromChar)
122import Control.Applicative ((<$>), pure)
123import Control.Applicative ((<$>), pure)
123import Control.Concurrent.MVar
124import Control.Concurrent.MVar
124import Control.Exception
125import Control.Exception
125− ( Exception, onException, throw, throwIO, finally )
126+ ( Exception, onException, throw, throwIO, finally
127+ , try, SomeException, fromException )
126import Control.Monad (foldM)
128import Control.Monad (foldM)
127import Data.ByteString (ByteString)
129import Data.ByteString (ByteString)
128import Data.Int (Int64)
130import Data.Int (Int64)
@@ -643,6 +645,51 @@ defaultReadWriteMode = DefaultReadWriteMode
643withTransaction :: Connection -> IO a -> IO a
645withTransaction :: Connection -> IO a -> IO a
644withTransaction = withTransactionMode defaultTransactionMode
646withTransaction = withTransactionMode defaultTransactionMode
645
647
648+-- | Execute an action inside of a 'Serializable' transaction. If a
649+-- serialization failure occurs, roll back the transaction and try again.
650+-- Be warned that this may execute the IO action multiple times.
651+--
652+-- More precisely, if a 'SqlError' arises whose 'sqlState' is @\"40001\"@
653+-- (@serialization_failure@), this will issue a @ROLLBACK@, then try the action
654+-- again. If any other exception arises, this will issue a @ROLLBACK@, but
655+-- will propagate the exception instead of retrying.
656+--
657+-- A 'Serializable' transaction creates the illusion that your program has
658+-- exclusive access to the database. This means that, even in a concurrent
659+-- setting, you can perform queries in sequence without having to worry about
660+-- what might happen between one statement and the next.
661+--
662+-- Think of it as STM, but without @retry@.
663+withTransactionSerializable :: ReadWriteMode -> Connection -> IO a -> IO a
664+withTransactionSerializable readWriteMode conn act =
665+ mask $ \restore ->
666+ retryLoop $ try $ do
667+ a <- restore act
668+ commit conn
669+ return a
670+ where
671+ retryLoop :: IO (Either SomeException a) -> IO a
672+ retryLoop act' = do
673+ beginMode mode conn
674+ r <- act'
675+ case r of
676+ Left e -> do
677+ rollback conn
678+ case fromException e of
679+ Just SqlError{..} | sqlState == serialization_failure
680+ -> retryLoop act'
681+ _ -> throwIO e
682+ Right a ->
683+ return a
684+
685+ mode = TransactionMode
686+ { isolationLevel = Serializable
687+ , readWriteMode
688+ }
689+
690+ -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
691+ serialization_failure = "40001"
692+
646-- | Execute an action inside a SQL transaction with a given isolation level.
693-- | Execute an action inside a SQL transaction with a given isolation level.
647withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
694withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
648withTransactionLevel lvl
695withTransactionLevel lvl
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+atomic :: Connection -> IO a -> IO a
10+atomic = withTransactionSerializable ReadWrite
11+
12+initCounter :: Connection -> IO ()
13+initCounter conn = do
14+ 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\
15+ \ CREATE TABLE testSerializableCounter (n INT)"
16+ 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)"
17+ return ()
18+
19+getCounter :: Connection -> IO Int
20+getCounter conn = do
21+ [Only n] <- query_ conn "SELECT n FROM testSerializableCounter"
22+ return n
23+
24+putCounter :: Connection -> Int -> IO ()
25+putCounter conn n = do
26+ 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
27+ return ()
28+
29+testSerializable :: TestEnv -> Test
30+testSerializable TestEnv{..} =
31+ TestCase $
32+ withConn $ \conn2 -> do
33+ initCounter conn
34+
35+ attemptCounter <- newIORef (0 :: Int)
36+ readyToBother <- newEmptyMVar
37+ bothered <- newEmptyMVar
38+ finished <- newEmptyMVar
39+
40+ _ <- forkIO $ do
41+ atomic conn2 $ do
42+ modifyIORef attemptCounter (+1)
43+ n <- getCounter conn2
44+ True <- tryPutMVar readyToBother ()
45+ readMVar bothered
46+ putCounter conn2 (n+1)
47+ putMVar finished ()
48+
49+ takeMVar readyToBother
50+ atomic conn $ do
51+ n <- getCounter conn
52+ putCounter conn (n+1)
53+ True <- tryPutMVar bothered ()
54+
55+ takeMVar finished
56+
57+ ac <- readIORef attemptCounter
58+ assertEqual "attemptCounter" 2 ac
59+
60+ ok <- E.catch (atomic conn (fail "Whoops") >> return False)
61+ (\(_ :: IOException) -> return True)
62+ assertBool "Exceptions (besides serialization failure) should be propagated through atomic" 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 ()