Transaction.hs

module Database.PostgreSQL.PQTypes.Transaction
  ( Savepoint (..)
  , withSavepoint
  , begin
  , commit
  , rollback
  , unsafeWithoutTransaction
  ) where

import Control.Monad.Catch
import Data.String
import GHC.Stack

import Data.Monoid.Utils
import Database.PostgreSQL.PQTypes.Class
import Database.PostgreSQL.PQTypes.Internal.Exception
import Database.PostgreSQL.PQTypes.Internal.Utils
import Database.PostgreSQL.PQTypes.SQL.Raw
import Database.PostgreSQL.PQTypes.Transaction.Settings
import Database.PostgreSQL.PQTypes.Utils

-- | Wrapper that represents savepoint name.
newtype Savepoint = Savepoint (RawSQL ())

instance IsString Savepoint where
  fromString = Savepoint . fromString

-- | Create a savepoint and roll back to it if given monadic action throws.
-- This may only be used if a transaction is already active. Note that it
-- provides something like \"nested transaction\".
--
-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>
withSavepoint :: (HasCallStack, MonadDB m, MonadMask m) => Savepoint -> m a -> m a
withSavepoint (Savepoint savepoint) m =
  fst
    <$> generalBracket
      (runQuery_ $ "SAVEPOINT" <+> savepoint)
      ( \() ec ->
          -- Hard mask asynchronous exceptions, otherwise the queries below can
          -- be interrupted and leave the savepoint in an unexpected state.
          uninterruptibleMask_ . runCleanup ec $ case ec of
            ExitCaseSuccess _ -> runQuery_ sqlReleaseSavepoint
            _ -> rollbackAndReleaseSavepoint
      )
      (\() -> m)
  where
    sqlReleaseSavepoint = "RELEASE SAVEPOINT" <+> savepoint
    rollbackAndReleaseSavepoint = do
      runQuery_ $ "ROLLBACK TO SAVEPOINT" <+> savepoint
      runQuery_ sqlReleaseSavepoint

----------------------------------------

-- Note: sql queries in below functions that modify transaction state need to
-- not be interruptible so we don't end up in unexpected transaction
-- state. However, getConnectionAcquisitionMode should be interruptible to not
-- lead to deadlocks if a connection ends up being used from multiple threads.

-- | Begin transaction using given transaction settings.
begin :: (HasCallStack, MonadDB m, MonadMask m) => m ()
begin = do
  getConnectionAcquisitionMode >>= \case
    AcquireOnDemand -> pure ()
    AcquireAndHold isolationLevel permissions -> uninterruptibleMask_ $ do
      runSQL_ $
        smconcat
          [ "BEGIN"
          , case isolationLevel of
              DefaultLevel -> ""
              ReadCommitted -> "ISOLATION LEVEL READ COMMITTED"
              RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"
              Serializable -> "ISOLATION LEVEL SERIALIZABLE"
          , case permissions of
              DefaultPermissions -> ""
              ReadOnly -> "READ ONLY"
              ReadWrite -> "READ WRITE"
          ]

-- | Commit active transaction using given transaction settings.
commit :: (HasCallStack, MonadDB m, MonadMask m) => m ()
commit = do
  getConnectionAcquisitionMode >>= \case
    AcquireOnDemand -> pure ()
    AcquireAndHold {} -> uninterruptibleMask_ $ do
      runSQL_ "COMMIT" `onException` beginNoException
      begin

-- | Rollback active transaction using given transaction settings.
rollback :: (HasCallStack, MonadDB m, MonadMask m) => m ()
rollback = do
  getConnectionAcquisitionMode >>= \case
    AcquireOnDemand -> pure ()
    AcquireAndHold {} -> uninterruptibleMask_ $ do
      runSQL_ "ROLLBACK" `onException` beginNoException
      begin

-- | Run a block of code without an open transaction.
--
-- This function is unsafe, because if there is a transaction in progress, it's
-- commited, so the atomicity guarantee is lost.
unsafeWithoutTransaction
  :: (HasCallStack, MonadDB m, MonadMask m)
  => m a
  -> m a
unsafeWithoutTransaction action = do
  getConnectionAcquisitionMode >>= \case
    AcquireOnDemand -> action
    AcquireAndHold {} ->
      fst
        <$> generalBracket
          (uninterruptibleMask_ $ runSQL_ "COMMIT" `onException` beginNoException)
          (\() ec -> runCleanup ec begin)
          (\() -> action)

----------------------------------------
-- Helpers

-- If COMMIT (or ROLLBACK) fails, e.g. with a serialization error, the server
-- has already rolled the transaction back, so start a new one to uphold the
-- invariant that a transaction is always active in the AcquireAndHold mode. If
-- that fails as well (e.g. because the connection is gone), suppress the error
-- so that the original exception propagates.
beginNoException :: (HasCallStack, MonadDB m, MonadMask m) => m ()
beginNoException = begin `catch` \DBException {} -> pure ()