@@ -123,19 +123,15 @@ import Blaze.ByteString.Builder
123123 ( Builder, fromByteString, toByteString )
124124import Blaze.ByteString.Builder.Char8 (fromChar)
125125import Control.Applicative ((<$>), pure)
126−import Control.Concurrent.MVar
127126import Control.Exception
128− ( Exception, onException, throw, throwIO, finally
129− , try, SomeException, fromException )
127+ ( Exception, throw, throwIO, finally )
130128import Control.Monad (foldM)
131129import Data.ByteString (ByteString)
132130import Data.Int (Int64)
133−import qualified Data.IntMap as IntMap
134131import Data.List (intersperse)
135132import Data.Monoid (mconcat)
136133import Data.Typeable (Typeable)
137−import Database.PostgreSQL.Simple.BuiltinTypes ( oid2typname )
138−import Database.PostgreSQL.Simple.Compat ( mask, (<>) )
134+import Database.PostgreSQL.Simple.Compat ( (<>) )
139135import Database.PostgreSQL.Simple.FromField (ResultError(..))
140136import Database.PostgreSQL.Simple.FromRow (FromRow(..))
141137import Database.PostgreSQL.Simple.Ok
@@ -144,6 +140,8 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
144140import Database.PostgreSQL.Simple.Types
145141 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
146142import Database.PostgreSQL.Simple.Internal as Base
143+import Database.PostgreSQL.Simple.Transaction
144+import Database.PostgreSQL.Simple.TypeInfo
147145import qualified Database.PostgreSQL.LibPQ as PQ
148146import qualified Data.ByteString.Char8 as B
149147import qualified Data.Text as T
@@ -589,166 +587,6 @@ ellipsis bs
589587 | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
590588 | otherwise = bs
591589
592−
593−-- | Of the four isolation levels defined by the SQL standard,
594−-- these are the three levels distinguished by PostgreSQL as of version 9.0.
595−-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>
596−-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
597−-- was equivalent to 'Serializable'.
598−
599−data IsolationLevel
600− = DefaultIsolationLevel -- ^ the isolation level will be taken from
601− -- PostgreSQL's per-connection
602− -- @default_transaction_isolation@ variable,
603− -- which is initialized according to the
604− -- server's config. The default configuration
605− -- is 'ReadCommitted'.
606− | ReadCommitted
607− | RepeatableRead
608− | Serializable
609− deriving (Show, Eq, Ord, Enum, Bounded)
610−
611−data ReadWriteMode
612− = DefaultReadWriteMode -- ^ the read-write mode will be taken from
613− -- PostgreSQL's per-connection
614− -- @default_transaction_read_only@ variable,
615− -- which is initialized according to the
616− -- server's config. The default configuration
617− -- is 'ReadWrite'.
618− | ReadWrite
619− | ReadOnly
620− deriving (Show, Eq, Ord, Enum, Bounded)
621−
622−data TransactionMode = TransactionMode {
623− isolationLevel :: !IsolationLevel,
624− readWriteMode :: !ReadWriteMode
625− } deriving (Show, Eq)
626−
627−defaultTransactionMode :: TransactionMode
628−defaultTransactionMode = TransactionMode
629− defaultIsolationLevel
630− defaultReadWriteMode
631−
632−defaultIsolationLevel :: IsolationLevel
633−defaultIsolationLevel = DefaultIsolationLevel
634−
635−defaultReadWriteMode :: ReadWriteMode
636−defaultReadWriteMode = DefaultReadWriteMode
637−
638−-- | Execute an action inside a SQL transaction.
639−--
640−-- This function initiates a transaction with a \"@begin
641−-- transaction@\" statement, then executes the supplied action. If
642−-- the action succeeds, the transaction will be completed with
643−-- 'Base.commit' before this function returns.
644−--
645−-- If the action throws /any/ kind of exception (not just a
646−-- PostgreSQL-related exception), the transaction will be rolled back using
647−-- 'rollback', then the exception will be rethrown.
648−withTransaction :: Connection -> IO a -> IO a
649−withTransaction = withTransactionMode defaultTransactionMode
650−
651−-- | Execute an action inside of a 'Serializable' transaction. If a
652−-- serialization failure occurs, roll back the transaction and try again.
653−-- Be warned that this may execute the IO action multiple times.
654−--
655−-- A 'Serializable' transaction creates the illusion that your program has
656−-- exclusive access to the database. This means that, even in a concurrent
657−-- setting, you can perform queries in sequence without having to worry about
658−-- what might happen between one statement and the next.
659−--
660−-- Think of it as STM, but without @retry@.
661−withTransactionSerializable :: Connection -> IO a -> IO a
662−withTransactionSerializable =
663− withTransactionModeRetry
664− TransactionMode
665− { isolationLevel = Serializable
666− , readWriteMode = ReadWrite
667− }
668− retryOnNotSerializable
669− where
670− retryOnNotSerializable exception =
671− case exception of
672− SqlError{..} | sqlState == serialization_failure
673− -> True
674− _ -> False
675− -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
676− serialization_failure = "40001"
677−
678−-- | Execute an action inside a SQL transaction with a given isolation level.
679−withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
680−withTransactionLevel lvl
681− = withTransactionMode defaultTransactionMode { isolationLevel = lvl }
682−
683−-- | Execute an action inside a SQL transaction with a given transaction mode.
684−withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
685−withTransactionMode mode conn act =
686− mask $ \restore -> do
687− beginMode mode conn
688− r <- restore act `onException` rollback conn
689− commit conn
690− return r
691−
692−-- | Like 'withTransactionMode', but also takes a custom callback to
693−-- determine if a transaction should be retried if an 'SqlError' occurs.
694−-- If the callback returns True, then the transaction will be retried.
695−-- If the callback returns False, or an exception other than an 'SqlError'
696−-- occurs then the transaction will be rolled back and the exception rethrown.
697−--
698−-- This is used to implement 'withTransactionSerializable'.
699−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
700−withTransactionModeRetry mode shouldRetry conn act =
701− mask $ \restore ->
702− retryLoop $ try $ do
703− a <- restore act
704− commit conn
705− return a
706− where
707− retryLoop :: IO (Either SomeException a) -> IO a
708− retryLoop act' = do
709− beginMode mode conn
710− r <- act'
711− case r of
712− Left e -> do
713− rollback conn
714− case fmap shouldRetry (fromException e) of
715− Just True -> retryLoop act'
716− _ -> throwIO e
717− Right a ->
718− return a
719−
720−-- | Rollback a transaction.
721−rollback :: Connection -> IO ()
722−rollback conn = execute_ conn "ABORT" >> return ()
723−
724−-- | Commit a transaction.
725−commit :: Connection -> IO ()
726−commit conn = execute_ conn "COMMIT" >> return ()
727−
728−-- | Begin a transaction.
729−begin :: Connection -> IO ()
730−begin = beginMode defaultTransactionMode
731−
732−-- | Begin a transaction with a given isolation level
733−beginLevel :: IsolationLevel -> Connection -> IO ()
734−beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }
735−
736−-- | Begin a transaction with a given transaction mode
737−beginMode :: TransactionMode -> Connection -> IO ()
738−beginMode mode conn = do
739− _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])
740− return ()
741− where
742− isolevel = case isolationLevel mode of
743− DefaultIsolationLevel -> ""
744− ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"
745− RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"
746− Serializable -> " ISOLATION LEVEL SERIALIZABLE"
747− readmode = case readWriteMode mode of
748− DefaultReadWriteMode -> ""
749− ReadWrite -> " READ WRITE"
750− ReadOnly -> " READ ONLY"
751−
752590fmtError :: String -> Query -> [Action] -> a
753591fmtError msg q xs = throw FormatError {
754592 fmtMessage = msg
@@ -1022,32 +860,3 @@ fmtError msg q xs = throw FormatError {
1022860-- UTF-8. If you use some other encoding, decoding may fail or give
1023861-- wrong results. In such cases, write a @newtype@ wrapper and a
1024862-- custom 'Result' instance to handle your encoding.
1025−
1026−getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
1027−getTypeInfo conn@Connection{..} oid =
1028− case oid2typname oid of
1029− Just name -> return $! TypeInfo { typ = NamedOid oid name
1030− , typelem = Nothing
1031− }
1032− Nothing -> modifyMVar connectionObjects $ \oidmap -> do
1033− case IntMap.lookup (oid2int oid) oidmap of
1034− Just typeinfo -> return (oidmap, typeinfo)
1035− Nothing -> do
1036− names <- query conn "SELECT p.oid, p.typname, c.oid, c.typname\
1037− \ FROM pg_type AS p LEFT OUTER JOIN pg_type AS c\
1038− \ ON c.oid = p.typelem\
1039− \ WHERE p.oid = ?"
1040− (Only oid)
1041− typinf <- case names of
1042− [] -> return $ throw (fatalError "invalid type oid")
1043− [(pOid, pTypName, mbCOid, mbCTypName)] ->
1044− return $! TypeInfo { typ = NamedOid pOid pTypName
1045− , typelem = do
1046− cOid <- mbCOid
1047− cTypName <- mbCTypName
1048− return $ NamedOid cOid cTypName
1049− }
1050− _ -> fail "typename query returned more than one result"
1051− -- oid is a primary key, so the query should
1052− -- never return more than one result
1053− return (IntMap.insert (oid2int oid) typinf oidmap, typinf)