diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.3.1.2 +Version: 0.3.2.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -75,7 +75,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.3.1.2 + tag: v0.3.2.0 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -98,6 +98,7 @@ -- , Base.insertID -- * Transaction handling , withTransaction + , withSavepoint -- , Base.autocommit , begin , commit diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -14,10 +14,8 @@ ) where -import Prelude hiding (catch) - import Control.Applicative -import Control.Exception +import Control.Exception as E import Data.Attoparsec.Char8 import Data.ByteString (ByteString) @@ -75,7 +73,7 @@ -- > createUser = catchJust constraintViolationE catcher $ execute conn ... -- > where -- > catcher (_, UniqueViolation "user_login_key") = ... --- > catcher (e, _) = throw e +-- > catcher (e, _) = throwIO e -- constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) constraintViolationE e = fmap ((,) e) $ constraintViolation e @@ -86,10 +84,10 @@ -- > createUser = catchViolation catcher $ execute conn ... -- > where -- > catcher _ (UniqueViolation "user_login_key") = ... --- > catcher e _ = throw e +-- > catcher e _ = throwIO e catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a -catchViolation f m = catch m - (\e -> maybe (throw e) (f e) $ constraintViolation e) +catchViolation f m = E.catch m + (\e -> maybe (throwIO e) (f e) $ constraintViolation e) -- Parsers just try to extract quoted strings from error messages, number -- of quoted strings depend on error type. diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -404,6 +404,9 @@ msg {-# INLINE ff #-} +-- | Compatible with both types. Conversions to type @b@ are +-- preferred, the conversion to type @a@ will be tried after +-- the 'Right' conversion fails. instance (FromField a, FromField b) => FromField (Either a b) where fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -115,12 +115,14 @@ newtype HStoreList = HStoreList [(Text,Text)] deriving (Typeable, Show) +-- | hstore instance ToHStore HStoreList where toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) instance ToField HStoreList where toField xs = toField (toHStore xs) +-- | hstore instance FromField HStoreList where fromField f mdat = do typ <- typename f diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal @@ -30,6 +33,7 @@ import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap +import Data.IORef import Data.Maybe(fromMaybe) import Data.String import Data.Typeable @@ -62,6 +66,7 @@ data Connection = Connection { connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) + , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64) } data SqlError = SqlError { @@ -138,6 +143,7 @@ PQ.ConnectionOk -> do connectionHandle <- newMVar conn connectionObjects <- newMVar (IntMap.empty) + connectionTempNameCounter <- newIORef 0 let wconn = Connection{..} version <- PQ.serverVersion conn let settings @@ -280,6 +286,7 @@ newNullConnection = do connectionHandle <- newMVar =<< PQ.newNullConnection connectionObjects <- newMVar IntMap.empty + connectionTempNameCounter <- newIORef 0 return Connection{..} data Row = Row { @@ -328,3 +335,9 @@ conversionError :: Exception err => err -> Conversion a conversionError err = Conversion $ \_ -> return (Errors [SomeException err]) + +newTempName :: Connection -> IO Query +newTempName Connection{..} = do + !n <- atomicModifyIORef connectionTempNameCounter + (\n -> let !n' = n+1 in (n', n')) + return $! Query $ B8.pack $ "temp" ++ show n diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs --- a/src/Database/PostgreSQL/Simple/Transaction.hs +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -8,7 +8,6 @@ , withTransactionMode , withTransactionModeRetry , withTransactionSerializable - , isSerializationError , TransactionMode(..) , IsolationLevel(..) , ReadWriteMode(..) @@ -21,13 +20,27 @@ , beginMode , commit , rollback + + -- * Savepoint + , withSavepoint + , Savepoint + , newSavepoint + , releaseSavepoint + , rollbackToSavepoint + , rollbackToAndReleaseSavepoint + + -- * Error predicates + , isSerializationError + , isNoActiveTransactionError + , isFailedTransactionError ) where -import Control.Exception hiding (mask) +import qualified Control.Exception as E +import Data.ByteString (ByteString) import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types -import Database.PostgreSQL.Simple.Compat(mask) +import Database.PostgreSQL.Simple.Compat (mask, (<>)) -- | Of the four isolation levels defined by the SQL standard, @@ -85,6 +98,8 @@ -- If the action throws /any/ kind of exception (not just a -- PostgreSQL-related exception), the transaction will be rolled back using -- 'rollback', then the exception will be rethrown. +-- +-- For nesting transactions, see 'withSavepoint'. withTransaction :: Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode @@ -107,17 +122,6 @@ } isSerializationError - -isSerializationError :: SqlError -> Bool -isSerializationError exception = - case exception of - SqlError{..} | sqlState == serialization_failure - -> True - _ -> False - where - -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html - serialization_failure = "40001" - -- | Execute an action inside a SQL transaction with a given isolation level. withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a withTransactionLevel lvl @@ -128,7 +132,7 @@ withTransactionMode mode conn act = mask $ \restore -> do beginMode mode conn - r <- restore act `onException` rollback conn + r <- restore act `E.onException` rollback conn commit conn return r @@ -142,21 +146,21 @@ withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a withTransactionModeRetry mode shouldRetry conn act = mask $ \restore -> - retryLoop $ try $ do + retryLoop $ E.try $ do a <- restore act commit conn return a where - retryLoop :: IO (Either SomeException a) -> IO a + retryLoop :: IO (Either E.SomeException a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of Left e -> do rollback conn - case fmap shouldRetry (fromException e) of + case fmap shouldRetry (E.fromException e) of Just True -> retryLoop act' - _ -> throwIO e + _ -> E.throwIO e Right a -> return a @@ -191,3 +195,69 @@ DefaultReadWriteMode -> "" ReadWrite -> " READ WRITE" ReadOnly -> " READ ONLY" + +------------------------------------------------------------------------ +-- Savepoint + +-- | Create a savepoint, and roll back to it if an error occurs. This may only +-- be used inside of a transaction, and provides a sort of +-- \"nested transaction\". +-- +-- See +withSavepoint :: Connection -> IO a -> IO a +withSavepoint conn body = + mask $ \restore -> do + sp <- newSavepoint conn + r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp + releaseSavepoint conn sp `E.catch` \err -> + if isFailedTransactionError err + then rollbackToAndReleaseSavepoint conn sp + else E.throwIO err + return r + +-- | Create a new savepoint. This may only be used inside of a transaction. +newSavepoint :: Connection -> IO Savepoint +newSavepoint conn = do + name <- newTempName conn + _ <- execute_ conn ("SAVEPOINT " <> name) + return (Savepoint name) + +-- | Destroy a savepoint, but retain its effects. +-- +-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if +-- the transaction is aborted due to an error. 'commit' would merely warn and +-- roll back. +releaseSavepoint :: Connection -> Savepoint -> IO () +releaseSavepoint conn (Savepoint name) = + execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () + +-- | Roll back to a savepoint. This will not release the savepoint. +rollbackToSavepoint :: Connection -> Savepoint -> IO () +rollbackToSavepoint conn (Savepoint name) = + execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () + +-- | Roll back to a savepoint and release it. This is like calling +-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a +-- round trip to the database server. +rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () +rollbackToAndReleaseSavepoint conn (Savepoint name) = + execute_ conn sql >> return () + where + sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name + +------------------------------------------------------------------------ +-- Error predicates +-- +-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html + +isSerializationError :: SqlError -> Bool +isSerializationError = isSqlState "40001" + +isNoActiveTransactionError :: SqlError -> Bool +isNoActiveTransactionError = isSqlState "25P01" + +isFailedTransactionError :: SqlError -> Bool +isFailedTransactionError = isSqlState "25P02" + +isSqlState :: ByteString -> SqlError -> Bool +isSqlState s SqlError{..} = sqlState == s diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -23,6 +23,7 @@ , Query(..) , Oid(..) , (:.)(..) + , Savepoint(..) ) where import Blaze.ByteString.Builder (toByteString) @@ -130,3 +131,6 @@ data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable) infixr 3 :. + +newtype Savepoint = Savepoint Query + deriving (Eq, Ord, Show, Read, Typeable) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} import Common import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.HStore +import qualified Database.PostgreSQL.Simple.Transaction as ST +import Control.Applicative import Control.Exception as E import Control.Monad import Data.ByteString (ByteString) @@ -27,6 +30,7 @@ , TestLabel "Time" . testTime , TestLabel "Array" . testArray , TestLabel "HStore" . testHStore + , TestLabel "Savepoint" . testSavepoint ] testBytea :: TestEnv -> Test @@ -117,6 +121,79 @@ let m = Only (HStoreMap (Map.fromList xs)) m' <- query conn "SELECT ?::hstore" m [m] @?= m' + +testSavepoint :: TestEnv -> Test +testSavepoint TestEnv{..} = TestCase $ do + True <- expectError ST.isNoActiveTransactionError $ + withSavepoint conn $ return () + + let getRows :: IO [Int] + getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a" + withTransaction conn $ do + execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)" + execute_ conn "INSERT INTO tmp_savepoint VALUES (1)" + [1] <- getRows + + withSavepoint conn $ do + execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" + [1,2] <- getRows + return () + [1,2] <- getRows + + withSavepoint conn $ do + execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" + [1,2,3] <- getRows + True <- expectError isUniqueViolation $ + execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" + True <- expectError ST.isFailedTransactionError getRows + + -- Body returning successfully after handling error, + -- but 'withSavepoint' will roll back without complaining. + return () + -- Rolling back clears the error condition. + [1,2] <- getRows + + -- 'withSavepoint' will roll back after an exception, even if the + -- exception wasn't SQL-related. + True <- expectError (== TestException) $ + withSavepoint conn $ do + execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" + [1,2,3] <- getRows + throwIO TestException + [1,2] <- getRows + + -- Nested savepoint can be rolled back while the + -- outer effects are retained. + withSavepoint conn $ do + execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" + True <- expectError isUniqueViolation $ + withSavepoint conn $ do + execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" + [1,2,3,4] <- getRows + execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" + [1,2,3] <- getRows + return () + [1,2,3] <- getRows + + return () + + -- Transaction committed successfully, even though there were errors + -- (but we rolled them back). + [1,2,3] <- getRows + + return () + + where + expectError p io = + (io >> return False) `E.catch` \ex -> + if p ex then return True else throwIO ex + isUniqueViolation SqlError{..} = sqlState == "23505" + +data TestException + = TestException + deriving (Eq, Show, Typeable) + +instance Exception TestException ------------------------------------------------------------------------