postgresql-simple 0.2.3.0 → 0.2.4.0
raw patch · 4 files changed
+127/−3 lines, 4 files
Files
- postgresql-simple.cabal +3/−2
- src/Database/PostgreSQL/Simple.hs +53/−1
- test/Main.hs +2/−0
- test/Serializable.hs +69/−0
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.2.3.0+Version: 0.2.4.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -66,7 +66,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.2.3.0+ tag: v0.2.4.0 test-suite test type: exitcode-stdio-1.0@@ -78,6 +78,7 @@ Bytea ExecuteMany Notify+ Serializable Time ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
src/Database/PostgreSQL/Simple.hs view
@@ -97,6 +97,7 @@ -- , Base.insertID -- * Transaction handling , withTransaction+ , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..) , ReadWriteMode(..)@@ -105,6 +106,7 @@ , defaultReadWriteMode , withTransactionLevel , withTransactionMode+ , withTransactionModeRetry -- , Base.autocommit , begin , beginLevel@@ -122,7 +124,8 @@ import Control.Applicative ((<$>), pure) import Control.Concurrent.MVar import Control.Exception- ( Exception, onException, throw, throwIO, finally )+ ( Exception, onException, throw, throwIO, finally+ , try, SomeException, fromException ) import Control.Monad (foldM) import Data.ByteString (ByteString) import Data.Int (Int64)@@ -643,6 +646,24 @@ withTransaction :: Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode +-- | Execute an action inside of a 'Serializable' transaction. If a+-- serialization failure occurs, roll back the transaction and try again.+-- Be warned that this may execute the IO action multiple times.+--+-- A 'Serializable' transaction creates the illusion that your program has+-- exclusive access to the database. This means that, even in a concurrent+-- setting, you can perform queries in sequence without having to worry about+-- what might happen between one statement and the next.+--+-- Think of it as STM, but without @retry@.+withTransactionSerializable :: Connection -> IO a -> IO a+withTransactionSerializable =+ withTransactionModeRetry+ TransactionMode+ { isolationLevel = Serializable+ , readWriteMode = ReadWrite+ }+ -- | Execute an action inside a SQL transaction with a given isolation level. withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a withTransactionLevel lvl@@ -656,6 +677,37 @@ r <- restore act `onException` rollback conn commit conn return r++-- | Like 'withTransactionMode', but if a 'SqlError' arises whose 'sqlState' is+-- @\"40001\"@ (@serialization_failure@), this will issue a @ROLLBACK@, then+-- try the action again. If any other exception arises, this will issue a+-- @ROLLBACK@, but will propagate the exception instead of retrying.+--+-- This is used to implement 'withTransactionSerializable'.+withTransactionModeRetry :: TransactionMode -> Connection -> IO a -> IO a+withTransactionModeRetry mode conn act =+ mask $ \restore ->+ retryLoop $ try $ do+ a <- restore act+ commit conn+ return a+ where+ retryLoop :: IO (Either SomeException a) -> IO a+ retryLoop act' = do+ beginMode mode conn+ r <- act'+ case r of+ Left e -> do+ rollback conn+ case fromException e of+ Just SqlError{..} | sqlState == serialization_failure+ -> retryLoop act'+ _ -> throwIO e+ Right a ->+ return a++ -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html+ serialization_failure = "40001" -- | Rollback a transaction. rollback :: Connection -> IO ()
test/Main.hs view
@@ -7,6 +7,7 @@ import Bytea import ExecuteMany import Notify+import Serializable import Time tests :: [TestEnv -> Test]@@ -15,6 +16,7 @@ , TestLabel "Notify" . testNotify , TestLabel "ExecuteMany" . testExecuteMany , TestLabel "Time" . testTime+ , TestLabel "Serializable" . testSerializable ] -- | Action for connecting to the database that will be used for testing.
+ test/Serializable.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Serializable (testSerializable) where++import Common+import Control.Concurrent+import Control.Exception as E+import Data.IORef++initCounter :: Connection -> IO ()+initCounter conn = do+ 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\+ \ CREATE TABLE testSerializableCounter (n INT)"+ 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)"+ return ()++getCounter :: Connection -> IO Int+getCounter conn = do+ [Only n] <- query_ conn "SELECT n FROM testSerializableCounter"+ return n++putCounter :: Connection -> Int -> IO ()+putCounter conn n = do+ 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)+ return ()++testSerializable :: TestEnv -> Test+testSerializable TestEnv{..} =+ TestCase $+ withConn $ \conn2 -> do+ initCounter conn++ attemptCounter <- newIORef (0 :: Int)+ readyToBother <- newEmptyMVar+ bothered <- newEmptyMVar+ finished <- newEmptyMVar++ _ <- forkIO $ do+ withTransactionSerializable conn2 $ do+ modifyIORef attemptCounter (+1)+ n <- getCounter conn2+ True <- tryPutMVar readyToBother ()+ readMVar bothered+ putCounter conn2 (n+1)+ putMVar finished ()++ takeMVar readyToBother+ withTransactionSerializable conn $ do+ n <- getCounter conn+ putCounter conn (n+1)+ True <- tryPutMVar bothered ()++ takeMVar finished++ ac <- readIORef attemptCounter+ assertEqual "attemptCounter" 2 ac++ ok <- E.catch (do withTransactionSerializable conn (fail "Whoops")+ return False)+ (\(_ :: IOException) -> return True)+ assertBool "Exceptions (besides serialization failure) should be\+ \ propagated through withTransactionSerializable"+ ok++ -- Make sure transaction isn't dangling+ 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345"+ 0 <- execute_ conn "ROLLBACK"+ -- This prints "NOTICE: there is no transaction in progress"+ [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter"+ return ()