@@ -1,7 +1,10 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
12{-# LANGUAGE ScopedTypeVariables #-}
23import Common
34import Database.PostgreSQL.Simple.FromField (FromField)
45import Database.PostgreSQL.Simple.HStore
6+import qualified Database.PostgreSQL.Simple.Transaction as ST
7+import Control.Applicative
58import Control.Exception as E
69import Control.Monad
710import Data.ByteString (ByteString)
@@ -27,6 +30,7 @@ tests =
2730 , TestLabel "Time" . testTime
2831 , TestLabel "Array" . testArray
2932 , TestLabel "HStore" . testHStore
33+ , TestLabel "Savepoint" . testSavepoint
3034 ]
3135
3236testBytea :: TestEnv -> Test
@@ -118,6 +122,79 @@ testHStore TestEnv{..} = TestCase $ do
118122 m' <- query conn "SELECT ?::hstore" m
119123 [m] @?= m'
120124
125+testSavepoint :: TestEnv -> Test
126+testSavepoint TestEnv{..} = TestCase $ do
127+ True <- expectError ST.isNoActiveTransactionError $
128+ withSavepoint conn $ return ()
129+
130+ let getRows :: IO [Int]
131+ getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
132+ withTransaction conn $ do
133+ execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
134+ execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
135+ [1] <- getRows
136+
137+ withSavepoint conn $ do
138+ execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
139+ [1,2] <- getRows
140+ return ()
141+ [1,2] <- getRows
142+
143+ withSavepoint conn $ do
144+ execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
145+ [1,2,3] <- getRows
146+ True <- expectError isUniqueViolation $
147+ execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
148+ True <- expectError ST.isFailedTransactionError getRows
149+
150+ -- Body returning successfully after handling error,
151+ -- but 'withSavepoint' will roll back without complaining.
152+ return ()
153+ -- Rolling back clears the error condition.
154+ [1,2] <- getRows
155+
156+ -- 'withSavepoint' will roll back after an exception, even if the
157+ -- exception wasn't SQL-related.
158+ True <- expectError (== TestException) $
159+ withSavepoint conn $ do
160+ execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
161+ [1,2,3] <- getRows
162+ throwIO TestException
163+ [1,2] <- getRows
164+
165+ -- Nested savepoint can be rolled back while the
166+ -- outer effects are retained.
167+ withSavepoint conn $ do
168+ execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
169+ True <- expectError isUniqueViolation $
170+ withSavepoint conn $ do
171+ execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
172+ [1,2,3,4] <- getRows
173+ execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
174+ [1,2,3] <- getRows
175+ return ()
176+ [1,2,3] <- getRows
177+
178+ return ()
179+
180+ -- Transaction committed successfully, even though there were errors
181+ -- (but we rolled them back).
182+ [1,2,3] <- getRows
183+
184+ return ()
185+
186+ where
187+ expectError p io =
188+ (io >> return False) `E.catch` \ex ->
189+ if p ex then return True else throwIO ex
190+ isUniqueViolation SqlError{..} = sqlState == "23505"
191+
192+data TestException
193+ = TestException
194+ deriving (Eq, Show, Typeable)
195+
196+instance Exception TestException
197+
121198------------------------------------------------------------------------
122199
123200-- | Action for connecting to the database that will be used for testing.