Permalink
Browse files

Use async exception mask in withTransaction

  • Loading branch information...
joeyadams committed Mar 8, 2012
1 parent c576a8c commit 797cc3ad1ab7ec0c46ea021c7c8078e8523b542b
Showing with 36 additions and 6 deletions.
  1. +3 −0 postgresql-simple.cabal
  2. +8 −6 src/Database/PostgreSQL/Simple.hs
  3. +25 −0 src/Database/PostgreSQL/Simple/Compat.hs
View
@@ -31,6 +31,9 @@ Library
-- Other-modules:
Database.PostgreSQL.Simple.Internal
+ Other-modules:
+ Database.PostgreSQL.Simple.Compat
+
Build-depends:
attoparsec >= 0.8.5.3,
base < 5,
@@ -108,7 +108,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import Control.Applicative ((<$>), pure)
import Control.Concurrent.MVar
-import Control.Exception (Exception, bracket, onException, throw, throwIO, finally)
+import Control.Exception (Exception, onException, throw, throwIO, finally)
import Control.Monad (foldM)
import Control.Monad.Fix (fix)
import Data.ByteString (ByteString)
@@ -119,6 +119,7 @@ import Data.List (intersperse)
import Data.Monoid (mappend, mconcat)
import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname)
+import Database.PostgreSQL.Simple.Compat (mask)
import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)
import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))
import Database.PostgreSQL.Simple.Result (ResultError(..))
@@ -532,11 +533,12 @@ withTransactionLevel lvl
-- | Execute an action inside a SQL transaction with a given transaction mode.
withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
-withTransactionMode mode conn act = do
- beginMode mode conn
- r <- act `onException` rollback conn
- commit conn
- return r
+withTransactionMode mode conn act =
+ mask $ \restore -> do
+ beginMode mode conn
+ r <- restore act `onException` rollback conn
+ commit conn
+ return r
-- | Rollback a transaction.
rollback :: Connection -> IO ()
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+-- | This is a module of its own, because it uses the CPP extension, which
+-- doesn't play well with the regex string literal in Simple.hs .
+module Database.PostgreSQL.Simple.Compat
+ ( mask
+ ) where
+
+import qualified Control.Exception as E
+
+-- | Like 'E.mask', but backported to base before version 4.3.0.
+--
+-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This
+-- could be fixed by changing the type signature, but it would require us to
+-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The
+-- 'withTransactionMode' function calls the restore callback only once, so we
+-- don't need that polymorphism.
+mask :: ((IO a -> IO a) -> IO b) -> IO b
+#if MIN_VERSION_base(4,3,0)
+mask io = E.mask $ \restore -> io restore
+#else
+mask io = do
+ b <- E.blocked
+ E.block $ io $ \m -> if b then m else E.unblock m
+#endif
+{-# INLINE mask #-}

0 comments on commit 797cc3a

Please sign in to comment.