postgresql-simple 0.3.1.2 → 0.3.2.0
raw patch · 9 files changed
+197/−29 lines, 9 files
Files
- postgresql-simple.cabal +2/−2
- src/Database/PostgreSQL/Simple.hs +1/−0
- src/Database/PostgreSQL/Simple/Errors.hs +5/−7
- src/Database/PostgreSQL/Simple/FromField.hs +3/−0
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +2/−0
- src/Database/PostgreSQL/Simple/Internal.hs +14/−1
- src/Database/PostgreSQL/Simple/Transaction.hs +89/−19
- src/Database/PostgreSQL/Simple/Types.hs +4/−0
- test/Main.hs +77/−0
postgresql-simple.cabal view
@@ -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
src/Database/PostgreSQL/Simple.hs view
@@ -98,6 +98,7 @@ -- , Base.insertID -- * Transaction handling , withTransaction+ , withSavepoint -- , Base.autocommit , begin , commit
src/Database/PostgreSQL/Simple/Errors.hs view
@@ -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.
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -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)
src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -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
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -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
src/Database/PostgreSQL/Simple/Transaction.hs view
@@ -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 <http://www.postgresql.org/docs/current/static/sql-savepoint.html>+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
src/Database/PostgreSQL/Simple/Types.hs view
@@ -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)
test/Main.hs view
@@ -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 ------------------------------------------------------------------------