ef1c64f · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Merge pull request #34 from joeyadams/withTransactionSerializable

Add withTransactionSerializable

commitef1c64f781529d60f75d320f3ba37f411c4d4698 authorLeon P Smith <leon@melding-monads.com> dateWed 22 Aug 2012, 09:26 (14 years ago) parenta67e230 a271140

4 files changed+125−1

compare with master

unifiedsplit

postgresql-simple.cabal+1 src/Database/PostgreSQL/Simple.hs+53−1 test/Main.hs+2 test/Serializable.hs+69

postgresql-simple.cabal+1

@@ -78,6 +78,7 @@ test-suite test

7878 Bytea

7979 ExecuteMany

8080 Notify

81+ Serializable

8182 Time

8283

8384 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

9797-- , Base.insertID

9898 -- * Transaction handling

9999 , withTransaction

100+ , withTransactionSerializable

100101 , TransactionMode(..)

101102 , IsolationLevel(..)

102103 , ReadWriteMode(..)

@@ -105,6 +106,7 @@ module Database.PostgreSQL.Simple

105106 , defaultReadWriteMode

106107 , withTransactionLevel

107108 , withTransactionMode

109+ , withTransactionModeRetry

108110-- , Base.autocommit

109111 , begin

110112 , beginLevel

@@ -122,7 +124,8 @@ import Blaze.ByteString.Builder.Char8 (fromChar)

122124import Control.Applicative ((<$>), pure)

123125import Control.Concurrent.MVar

124126import Control.Exception

125− ( Exception, onException, throw, throwIO, finally )

127+ ( Exception, onException, throw, throwIO, finally

128+ , try, SomeException, fromException )

126129import Control.Monad (foldM)

127130import Data.ByteString (ByteString)

128131import Data.Int (Int64)

@@ -643,6 +646,24 @@ defaultReadWriteMode = DefaultReadWriteMode

643646withTransaction :: Connection -> IO a -> IO a

644647withTransaction = withTransactionMode defaultTransactionMode

645648

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+

646667-- | Execute an action inside a SQL transaction with a given isolation level.

647668withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a

648669withTransactionLevel lvl

@@ -657,6 +678,37 @@ withTransactionMode mode conn act =

657678 commit conn

658679 return r

659680

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+

660712-- | Rollback a transaction.

661713rollback :: Connection -> IO ()

662714rollback conn = execute_ conn "ABORT" >> return ()

test/Main.hs+2

@@ -7,6 +7,7 @@ import System.IO

77import Bytea

88import ExecuteMany

99import Notify

10+import Serializable

1011import Time

1112

1213tests :: [TestEnv -> Test]

@@ -15,6 +16,7 @@ tests =

1516 , TestLabel "Notify" . testNotify

1617 , TestLabel "ExecuteMany" . testExecuteMany

1718 , TestLabel "Time" . testTime

19+ , TestLabel "Serializable" . testSerializable

1820 ]

1921

2022-- | 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

4+import Common

5+import Control.Concurrent

6+import Control.Exception as E

7+import Data.IORef

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 ()