module Database.PostgreSQL.PQTypes.Transaction (
Savepoint(..)
, withSavepoint
, withTransaction
, begin
, commit
, rollback
, withTransaction'
, begin'
, commit'
, rollback'
) where
import Control.Monad
import Control.Monad.Catch
import Data.String
import Data.Typeable
import qualified Data.ByteString as BS
import System.IO.Unsafe
import Data.Monoid.Space
import Data.Monoid.Utils
import Database.PostgreSQL.PQTypes.Class
import Database.PostgreSQL.PQTypes.Internal.Exception
import Database.PostgreSQL.PQTypes.SQL.Raw
import Database.PostgreSQL.PQTypes.Transaction.Settings
import Database.PostgreSQL.PQTypes.Utils
newtype Savepoint = Savepoint (RawSQL ())
instance IsString Savepoint where
fromString = Savepoint . fromString
withSavepoint :: (MonadDB m, MonadMask m) => Savepoint -> m a -> m a
withSavepoint (Savepoint savepoint) m = mask $ \restore -> do
runQuery_ $ "SAVEPOINT" <+> savepoint
res <- restore m `onException` rollbackAndReleaseSavepoint
runQuery_ sqlReleaseSavepoint
return res
where
sqlReleaseSavepoint = "RELEASE SAVEPOINT" <+> savepoint
rollbackAndReleaseSavepoint = do
runQuery_ $ "ROLLBACK TO SAVEPOINT" <+> savepoint
runQuery_ sqlReleaseSavepoint
withTransaction :: (MonadDB m, MonadMask m) => m a -> m a
withTransaction m = getTransactionSettings >>= flip withTransaction' m
begin :: MonadDB m => m ()
begin = getTransactionSettings >>= begin'
commit :: MonadDB m => m ()
commit = getTransactionSettings >>= commit'
rollback :: MonadDB m => m ()
rollback = getTransactionSettings >>= rollback'
withTransaction' :: forall m a. (MonadDB m, MonadMask m)
=> TransactionSettings -> m a -> m a
withTransaction' ts m = mask $ exec 1
where
exec :: Integer -> (forall r. m r -> m r) -> m a
exec !n restore = handleJust expred (\_ -> do
unsafePerformIO $ do
BS.appendFile "/home/unknown/transaction.txt" "."
return $ return ()
exec (succ n) restore
) $ do
begin' ts
res <- restore m `onException` rollback' ts
commit' ts
return res
where
expred :: DBException -> Maybe ()
expred DBException{..} = do
RestartPredicate f <- tsRestartPredicate ts
err <- cast dbeError
guard $ f err n
begin' :: MonadDB m => TransactionSettings -> m ()
begin' ts = runSQL_ . mintercalate " " $ ["BEGIN", isolationLevel, permissions]
where
isolationLevel = case tsIsolationLevel ts of
DefaultLevel -> ""
ReadCommitted -> "ISOLATION LEVEL READ COMMITTED"
RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"
Serializable -> "ISOLATION LEVEL SERIALIZABLE"
permissions = case tsPermissions ts of
DefaultPermissions -> ""
ReadOnly -> "READ ONLY"
ReadWrite -> "READ WRITE"
commit' :: MonadDB m => TransactionSettings -> m ()
commit' ts = do
runSQL_ "COMMIT"
when (tsAutoTransaction ts) $
begin' ts
rollback' :: MonadDB m => TransactionSettings -> m ()
rollback' ts = do
runSQL_ "ROLLBACK"
when (tsAutoTransaction ts) $
begin' ts