# LANGUAGE BlockArguments #
# LANGUAGE DataKinds #
# LANGUAGE DerivingStrategies #
# LANGUAGE DerivingVia #
# LANGUAGE FlexibleContexts #
# LANGUAGE FlexibleInstances #
# LANGUAGE FunctionalDependencies #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE KindSignatures #
# LANGUAGE LambdaCase #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE NamedFieldPuns #
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
# LANGUAGE TypeFamilies #
# LANGUAGE TypeOperators #
# LANGUAGE UndecidableInstances #
module Database.PostgreSQL.Tx.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** Internals
    module Database.PostgreSQL.Tx.Internal
  ) where

import Control.Exception (Exception(toException), SomeException, catch, throwIO)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT))
import Data.Kind (Constraint)
import GHC.TypeLits (ErrorMessage(Text), TypeError)

  | The transaction monad .  all database integrations , regardless of
-- library, into a single monad. The @r@ type parameter represents the reader
-- environment needed for applicable database libraries. For example,
-- @postgresql-simple@ needs a @Connection@ to run its functions, so
-- its interface will require that we can obtain a @Connection@ from the @r@
  using the ' TxEnv ' type class .
--
  @since 0.2.0.0
newtype TxM r a = UnsafeTxM
  { -- | Convert a 'TxM' action to raw 'ReaderT' over 'IO'. This is provided only to give
  adaptor libraries access to the underlying ' IO ' that ' TxM ' wraps .
    --
  @since 0.2.0.0
    unsafeUnTxM :: ReaderT r IO a
  } deriving newtype (Functor, Applicative, Monad, MonadFail)
    deriving (Semigroup, Monoid) via (r -> IO a)

-- | Run an 'IO' action in 'TxM'. Use this function with care - arbitrary 'IO'
-- should only be run within a transaction when truly necessary.
--
  @since 0.2.0.0
unsafeRunIOInTxM :: IO a -> TxM r a
unsafeRunIOInTxM = UnsafeTxM . liftIO

-- | Construct a 'TxM' using a reader function. Use this function with care -
-- arbitrary 'IO' should only be run within a transaction when truly necessary.
--
  @since 0.2.0.0
unsafeMkTxM :: (r -> IO a) -> TxM r a
unsafeMkTxM = UnsafeTxM . ReaderT

  | Similar to ' unsafeMkTxM ' but allows for constructing a ' TxM ' with a
-- reader function using a specific value from the environment.
-- Use this function with care - arbitrary 'IO' should only be run
-- within a transaction when truly necessary.
--
  @since 0.2.0.0
unsafeMksTxM :: (TxEnv a r) => (a -> IO b) -> TxM r b
unsafeMksTxM f =
  unsafeMkTxM \r -> unsafeRunTxM r do
    a <- askTxEnv
    unsafeRunIOInTxM $ f a

-- | The 'TxM' monad discourages performing arbitrary 'IO' within a
-- transaction, so this instance generates a type error when client code tries
-- to call 'liftIO'.
--
  @since 0.1.0.0
instance
  ( TypeError
      ('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")
  ) => MonadIO (TxM r)
  where
  liftIO = undefined

  | Run a ' TxM ' to ' IO ' given the database runtime environment @r@.
-- Use of this function outside of test suites should be rare.
--
  @since 0.2.0.0
unsafeRunTxM :: r -> TxM r a -> IO a
unsafeRunTxM r x = runReaderT (unsafeUnTxM x) r

-- | Run a 'TxM' action in 'IO' via the provided runner function. Use this
-- function with care - arbitrary 'IO' should only be run within a transaction
-- when truly necessary.
--
  @since 0.2.0.0
unsafeWithRunInIOTxM :: ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b
unsafeWithRunInIOTxM inner = unsafeMkTxM \r -> inner (unsafeRunTxM r)

-- | A type class for specifying how to acquire an environment value
-- to be used for running an implementation of a database library.
-- For example, your database library will likely require some sort of
-- connection value to discharge its effects; in this case, you'd want to
-- define an instance of @TxEnv MyDBEnv Connection@ and use @TxM MyDBEnv@
-- as your monad for executing transactions.
--
-- Note that implementations should take care and ensure that multiple
  instances are compatible with one another . For example , let 's say you
  have instances for both @TxEnv E  . Connection@ and
  @TxEnv E LibPQ.Connection@ ; if both of these implementations are grabbing
-- connections from a pool, you will end up with each of those database
-- libraries using different connections, and thus, would be running in
-- separate transactions!
--
  @since 0.2.0.0
class TxEnv a r where

  -- | Acquire a value @a@ via the reader environment @r@ which assists in
  -- running a 'TxM' in a transaction.
  --
  @since 0.2.0.0
  lookupTxEnv :: r -> a

askTxEnv :: (TxEnv a r) => TxM r a
askTxEnv = unsafeMkTxM (pure . lookupTxEnv)

-- | Analogous to 'lookupTxEnv' but can be run in 'IO' instead of 'TxM'.
--
  @since 0.2.0.0
unsafeLookupTxEnvIO :: (TxEnv a r) => r -> IO a
unsafeLookupTxEnvIO r = unsafeRunTxM r askTxEnv

  | Type family which allows for specifying several ' TxEnv ' constraints as
-- a type-level list.
--
  @since 0.2.0.0
type family TxEnvs (xs :: [*]) r :: Constraint where
  TxEnvs '[] r = ()
  TxEnvs (x ': xs) r = (TxEnv x r, TxEnvs xs r)

-- | Throw an exception.
--
  @since 0.2.0.0
throwExceptionTx :: (Exception e) => e -> TxM r a
throwExceptionTx = unsafeRunIOInTxM . throwIO

-- | Catch an exception and map it to another exception type before rethrowing.
--
  @since 0.2.0.0
mapExceptionTx
  :: (Exception e, Exception e')
  => (e -> Maybe e')
  -> TxM r a
  -> TxM r a
mapExceptionTx mapper action = do
  unsafeWithRunInIOTxM \run -> do
    catch (run action) \ex -> do
      case mapper ex of
        Nothing -> throwIO ex
        Just ex' -> throwIO ex'

-- | Unified exception type thrown from the database.
--
-- Each database backend may throw different types of exceptions.
-- As a user of @postgresql-tx@, ideally we should be able to
-- detect exceptions from the database without needing to catch
-- the database backend's exception type.
--
-- The 'errcode' field allows us to introspect the postgresql
-- @errcode@; see -appendix.html
--
-- If you need to inspect the exact exception thrown by a database
-- backend, use the 'cause' field.
data TxException = TxException
  { errcode :: Maybe String
  , cause :: SomeException
  } deriving stock (Show)

instance Exception TxException

  | PostgreSQL @errcode@ for @serialization_failure@.
errcode'serialization_failure :: String
errcode'serialization_failure = "40001"

-- | PostgreSQL @errcode@ for @deadlock_detected@.
errcode'deadlock_detected :: String
errcode'deadlock_detected = "40P01"

  | Checks if the ' errcode ' of a ' TxException ' matches the supplied predicate .
-- If the 'errcode' is 'Nothing', returns 'False'.
hasErrcode :: (String -> Bool) -> TxException -> Bool
hasErrcode p TxException { errcode } = any p errcode

-- | Useful as a predicate to indicate when to retry transactions which are
-- run at isolation level @serializable@
shouldRetryTx :: TxException -> Bool
shouldRetryTx =
  hasErrcode
    (`elem`
      [ errcode'serialization_failure
      , errcode'deadlock_detected
      ])

  | Construct a ' TxException ' from an @errcode@ accessing function
-- and the 'cause' exception.
--
-- Note that this function should only be used by libraries
-- which are implementing a database backend for @postgresql-tx@.
unsafeMkTxException
  :: (Exception e) => (e -> Maybe String) -> e -> TxException
unsafeMkTxException f e =
  TxException
    { errcode = f e
    , cause = toException e
    }

-- $disclaimer
--
-- Changes to this module will not be reflected in the library's version
-- updates.

# LANGUAGE OverloadedStrings #
# LANGUAGE RankNTypes #
 * Disclaimer
 $disclaimer
 ** Internals
 library, into a single monad. The @r@ type parameter represents the reader
 environment needed for applicable database libraries. For example,
 @postgresql-simple@ needs a @Connection@ to run its functions, so
 its interface will require that we can obtain a @Connection@ from the @r@

 | Convert a 'TxM' action to raw 'ReaderT' over 'IO'. This is provided only to give

 | Run an 'IO' action in 'TxM'. Use this function with care - arbitrary 'IO'
 should only be run within a transaction when truly necessary.

 | Construct a 'TxM' using a reader function. Use this function with care -
 arbitrary 'IO' should only be run within a transaction when truly necessary.

 reader function using a specific value from the environment.
 Use this function with care - arbitrary 'IO' should only be run
 within a transaction when truly necessary.

 | The 'TxM' monad discourages performing arbitrary 'IO' within a
 transaction, so this instance generates a type error when client code tries
 to call 'liftIO'.

 Use of this function outside of test suites should be rare.

 | Run a 'TxM' action in 'IO' via the provided runner function. Use this
 function with care - arbitrary 'IO' should only be run within a transaction
 when truly necessary.

 | A type class for specifying how to acquire an environment value
 to be used for running an implementation of a database library.
 For example, your database library will likely require some sort of
 connection value to discharge its effects; in this case, you'd want to
 define an instance of @TxEnv MyDBEnv Connection@ and use @TxM MyDBEnv@
 as your monad for executing transactions.

 Note that implementations should take care and ensure that multiple
 connections from a pool, you will end up with each of those database
 libraries using different connections, and thus, would be running in
 separate transactions!

 | Acquire a value @a@ via the reader environment @r@ which assists in
 running a 'TxM' in a transaction.

 | Analogous to 'lookupTxEnv' but can be run in 'IO' instead of 'TxM'.

 a type-level list.

 | Throw an exception.

 | Catch an exception and map it to another exception type before rethrowing.

 | Unified exception type thrown from the database.

 Each database backend may throw different types of exceptions.
 As a user of @postgresql-tx@, ideally we should be able to
 detect exceptions from the database without needing to catch
 the database backend's exception type.

 The 'errcode' field allows us to introspect the postgresql
 @errcode@; see -appendix.html

 If you need to inspect the exact exception thrown by a database
 backend, use the 'cause' field.
 | PostgreSQL @errcode@ for @deadlock_detected@.
 If the 'errcode' is 'Nothing', returns 'False'.
 | Useful as a predicate to indicate when to retry transactions which are
 run at isolation level @serializable@
 and the 'cause' exception.

 Note that this function should only be used by libraries
 which are implementing a database backend for @postgresql-tx@.
 $disclaimer

 Changes to this module will not be reflected in the library's version
 updates.
# LANGUAGE BlockArguments #
# LANGUAGE DataKinds #
# LANGUAGE DerivingStrategies #
# LANGUAGE DerivingVia #
# LANGUAGE FlexibleContexts #
# LANGUAGE FlexibleInstances #
# LANGUAGE FunctionalDependencies #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE KindSignatures #
# LANGUAGE LambdaCase #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE NamedFieldPuns #
# LANGUAGE TypeFamilies #
# LANGUAGE TypeOperators #
# LANGUAGE UndecidableInstances #
module Database.PostgreSQL.Tx.Internal

    module Database.PostgreSQL.Tx.Internal
  ) where

import Control.Exception (Exception(toException), SomeException, catch, throwIO)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT))
import Data.Kind (Constraint)
import GHC.TypeLits (ErrorMessage(Text), TypeError)

  | The transaction monad .  all database integrations , regardless of
  using the ' TxEnv ' type class .
  @since 0.2.0.0
newtype TxM r a = UnsafeTxM
  adaptor libraries access to the underlying ' IO ' that ' TxM ' wraps .
  @since 0.2.0.0
    unsafeUnTxM :: ReaderT r IO a
  } deriving newtype (Functor, Applicative, Monad, MonadFail)
    deriving (Semigroup, Monoid) via (r -> IO a)

  @since 0.2.0.0
unsafeRunIOInTxM :: IO a -> TxM r a
unsafeRunIOInTxM = UnsafeTxM . liftIO

  @since 0.2.0.0
unsafeMkTxM :: (r -> IO a) -> TxM r a
unsafeMkTxM = UnsafeTxM . ReaderT

  | Similar to ' unsafeMkTxM ' but allows for constructing a ' TxM ' with a
  @since 0.2.0.0
unsafeMksTxM :: (TxEnv a r) => (a -> IO b) -> TxM r b
unsafeMksTxM f =
  unsafeMkTxM \r -> unsafeRunTxM r do
    a <- askTxEnv
    unsafeRunIOInTxM $ f a

  @since 0.1.0.0
instance
  ( TypeError
      ('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")
  ) => MonadIO (TxM r)
  where
  liftIO = undefined

  | Run a ' TxM ' to ' IO ' given the database runtime environment @r@.
  @since 0.2.0.0
unsafeRunTxM :: r -> TxM r a -> IO a
unsafeRunTxM r x = runReaderT (unsafeUnTxM x) r

  @since 0.2.0.0
unsafeWithRunInIOTxM :: ((forall a. TxM r a -> IO a) -> IO b) -> TxM r b
unsafeWithRunInIOTxM inner = unsafeMkTxM \r -> inner (unsafeRunTxM r)

  instances are compatible with one another . For example , let 's say you
  have instances for both @TxEnv E  . Connection@ and
  @TxEnv E LibPQ.Connection@ ; if both of these implementations are grabbing
  @since 0.2.0.0
class TxEnv a r where

  @since 0.2.0.0
  lookupTxEnv :: r -> a

askTxEnv :: (TxEnv a r) => TxM r a
askTxEnv = unsafeMkTxM (pure . lookupTxEnv)

  @since 0.2.0.0
unsafeLookupTxEnvIO :: (TxEnv a r) => r -> IO a
unsafeLookupTxEnvIO r = unsafeRunTxM r askTxEnv

  | Type family which allows for specifying several ' TxEnv ' constraints as
  @since 0.2.0.0
type family TxEnvs (xs :: [*]) r :: Constraint where
  TxEnvs '[] r = ()
  TxEnvs (x ': xs) r = (TxEnv x r, TxEnvs xs r)

  @since 0.2.0.0
throwExceptionTx :: (Exception e) => e -> TxM r a
throwExceptionTx = unsafeRunIOInTxM . throwIO

  @since 0.2.0.0
mapExceptionTx
  :: (Exception e, Exception e')
  => (e -> Maybe e')
  -> TxM r a
  -> TxM r a
mapExceptionTx mapper action = do
  unsafeWithRunInIOTxM \run -> do
    catch (run action) \ex -> do
      case mapper ex of
        Nothing -> throwIO ex
        Just ex' -> throwIO ex'

data TxException = TxException
  { errcode :: Maybe String
  , cause :: SomeException
  } deriving stock (Show)

instance Exception TxException

  | PostgreSQL @errcode@ for @serialization_failure@.
errcode'serialization_failure :: String
errcode'serialization_failure = "40001"

errcode'deadlock_detected :: String
errcode'deadlock_detected = "40P01"

  | Checks if the ' errcode ' of a ' TxException ' matches the supplied predicate .
hasErrcode :: (String -> Bool) -> TxException -> Bool
hasErrcode p TxException { errcode } = any p errcode

shouldRetryTx :: TxException -> Bool
shouldRetryTx =
  hasErrcode
    (`elem`
      [ errcode'serialization_failure
      , errcode'deadlock_detected
      ])

  | Construct a ' TxException ' from an @errcode@ accessing function
unsafeMkTxException
  :: (Exception e) => (e -> Maybe String) -> e -> TxException
unsafeMkTxException f e =
  TxException
    { errcode = f e
    , cause = toException e
    }

