Transaction.hs

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

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

-- |
-- Module:      Database.PostgreSQL.Simple.Transaction
-- Copyright:   (c) 2011-2013 Leon P Smith
--              (c) 2013 Joey Adams
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
module Database.PostgreSQL.Simple.Transaction
  ( -- * Transaction handling
    withTransaction,
    withTransactionLevel,
    withTransactionMode,
    withTransactionModeRetry,
    withTransactionModeRetry',
    withTransactionSerializable,
    TransactionMode (..),
    IsolationLevel (..),
    ReadWriteMode (..),
    defaultTransactionMode,
    defaultIsolationLevel,
    defaultReadWriteMode,
    --    , Base.autocommit
    begin,
    beginLevel,
    beginMode,
    commit,
    rollback,

    -- * Savepoint
    withSavepoint,
    Savepoint,
    newSavepoint,
    releaseSavepoint,
    rollbackToSavepoint,
    rollbackToAndReleaseSavepoint,

    -- * Error predicates
    isSerializationError,
    isNoActiveTransactionError,
    isFailedTransactionError,
  )
where

import qualified Control.Exception as E
import qualified Data.ByteString as B
import Database.PostgreSQL.Simple.Compat (mask)
import Database.PostgreSQL.Simple.Errors
import Database.PostgreSQL.Simple.Internal
import Database.PostgreSQL.Simple.Types

-- | Of the four isolation levels defined by the SQL standard,
-- these are the three levels distinguished by PostgreSQL as of version 9.0.
-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>
-- for more information.   Note that prior to PostgreSQL 9.0, 'RepeatableRead'
-- was equivalent to 'Serializable'.
data IsolationLevel
  = -- | the isolation level will be taken from
    --   PostgreSQL's per-connection
    --   @default_transaction_isolation@ variable,
    --   which is initialized according to the
    --   server's config.  The default configuration
    --   is 'ReadCommitted'.
    DefaultIsolationLevel
  | ReadCommitted
  | RepeatableRead
  | Serializable
  deriving (Show, Eq, Ord, Enum, Bounded)

data ReadWriteMode
  = -- | the read-write mode will be taken from
    --   PostgreSQL's per-connection
    --   @default_transaction_read_only@ variable,
    --   which is initialized according to the
    --   server's config.  The default configuration
    --   is 'ReadWrite'.
    DefaultReadWriteMode
  | ReadWrite
  | ReadOnly
  deriving (Show, Eq, Ord, Enum, Bounded)

data TransactionMode = TransactionMode
  { isolationLevel :: !IsolationLevel,
    readWriteMode :: !ReadWriteMode
  }
  deriving (Show, Eq)

defaultTransactionMode :: TransactionMode
defaultTransactionMode =
  TransactionMode
    defaultIsolationLevel
    defaultReadWriteMode

defaultIsolationLevel :: IsolationLevel
defaultIsolationLevel = DefaultIsolationLevel

defaultReadWriteMode :: ReadWriteMode
defaultReadWriteMode = DefaultReadWriteMode

-- | Execute an action inside a SQL transaction.
--
-- This function initiates a transaction with a \"@begin
-- transaction@\" statement, then executes the supplied action.  If
-- the action succeeds, the transaction will be completed with
-- 'Base.commit' before this function returns.
--
-- 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

-- | Execute an action inside of a 'Serializable' transaction.  If a
-- serialization failure occurs, roll back the transaction and try again.
-- Be warned that this may execute the IO action multiple times.
--
-- A 'Serializable' transaction creates the illusion that your program has
-- exclusive access to the database.  This means that, even in a concurrent
-- setting, you can perform queries in sequence without having to worry about
-- what might happen between one statement and the next.
--
-- Think of it as STM, but without @retry@.
withTransactionSerializable :: Connection -> IO a -> IO a
withTransactionSerializable =
  withTransactionModeRetry
    TransactionMode
      { isolationLevel = Serializable,
        readWriteMode = ReadWrite
      }
    isSerializationError

-- | Execute an action inside a SQL transaction with a given isolation level.
withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
withTransactionLevel lvl =
  withTransactionMode defaultTransactionMode {isolationLevel = lvl}

-- | Execute an action inside a SQL transaction with a given transaction mode.
withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
withTransactionMode mode conn act =
  mask $ \restore -> do
    beginMode mode conn
    r <- restore act `E.onException` rollback_ conn
    commit conn
    return r

-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
withTransactionModeRetry = withTransactionModeRetry'

-- | Like 'withTransactionMode', but also takes a custom callback to
-- determine if a transaction should be retried if an exception occurs.
-- If the callback returns 'True', then the transaction will be retried.
-- If the callback returns 'False', or an exception other than an @e@
-- occurs then the transaction will be rolled back and the exception rethrown.
--
-- This is used to implement 'withTransactionSerializable'.
withTransactionModeRetry' :: forall a e. (E.Exception e) => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
withTransactionModeRetry' mode shouldRetry conn act =
  mask $ \restore ->
    retryLoop $ E.try $ do
      a <- restore act `E.onException` rollback_ conn
      commit conn
      return a
  where
    retryLoop :: IO (Either e a) -> IO a
    retryLoop act' = do
      beginMode mode conn
      r <- act'
      case r of
        Left e ->
          case shouldRetry e of
            True -> retryLoop act'
            False -> E.throwIO e
        Right a ->
          return a

-- | Rollback a transaction.
rollback :: Connection -> IO ()
rollback conn = execute_ conn "ROLLBACK" >> return ()

-- | Rollback a transaction, ignoring any @IOErrors@
rollback_ :: Connection -> IO ()
rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()

-- | Commit a transaction.
commit :: Connection -> IO ()
commit conn = execute_ conn "COMMIT" >> return ()

-- | Begin a transaction.
begin :: Connection -> IO ()
begin = beginMode defaultTransactionMode

-- | Begin a transaction with a given isolation level
beginLevel :: IsolationLevel -> Connection -> IO ()
beginLevel lvl = beginMode defaultTransactionMode {isolationLevel = lvl}

-- | Begin a transaction with a given transaction mode
beginMode :: TransactionMode -> Connection -> IO ()
beginMode mode conn = do
  _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])
  return ()
  where
    isolevel = case isolationLevel mode of
      DefaultIsolationLevel -> ""
      ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"
      RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"
      Serializable -> " ISOLATION LEVEL SERIALIZABLE"
    readmode = case readWriteMode mode of
      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 <https://www.postgresql.org/docs/9.5/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