{-# LANGUAGE OverloadedStrings #-}

module Hasql.Private.TransactionIO where

-- base
import           Control.Applicative

-- bytestring
import           Data.ByteString                  (ByteString)

-- bytestring-tree-builder
import           ByteString.TreeBuilder

-- transformers
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Reader

-- mtl
import           Control.Monad.Error.Class

-- unliftio-core
import           Control.Monad.IO.Unlift

-- safe-exceptions
import           Control.Exception.Safe

-- resourcet
import           Control.Monad.Trans.Resource
import           Data.Acquire

-- hasql
import           Hasql.Session
import qualified Hasql.Session                    as Session
import           Hasql.Statement

-- hasql-streaming
import           Hasql.Private.Session.MonadThrow
import           Hasql.Private.Session.UnliftIO
import qualified Hasql.Private.Statements         as Statements
import           Hasql.Private.Types

-- | A mixture of Hasql statements and arbitrary IO that is all performed during a single transaction
newtype TransactionIO a = TransactionIO (ReaderT Transaction Session a)
  deriving ((forall a b. (a -> b) -> TransactionIO a -> TransactionIO b)
-> (forall a b. a -> TransactionIO b -> TransactionIO a)
-> Functor TransactionIO
forall a b. a -> TransactionIO b -> TransactionIO a
forall a b. (a -> b) -> TransactionIO a -> TransactionIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TransactionIO a -> TransactionIO b
fmap :: forall a b. (a -> b) -> TransactionIO a -> TransactionIO b
$c<$ :: forall a b. a -> TransactionIO b -> TransactionIO a
<$ :: forall a b. a -> TransactionIO b -> TransactionIO a
Functor, Functor TransactionIO
Functor TransactionIO =>
(forall a. a -> TransactionIO a)
-> (forall a b.
    TransactionIO (a -> b) -> TransactionIO a -> TransactionIO b)
-> (forall a b c.
    (a -> b -> c)
    -> TransactionIO a -> TransactionIO b -> TransactionIO c)
-> (forall a b.
    TransactionIO a -> TransactionIO b -> TransactionIO b)
-> (forall a b.
    TransactionIO a -> TransactionIO b -> TransactionIO a)
-> Applicative TransactionIO
forall a. a -> TransactionIO a
forall a b. TransactionIO a -> TransactionIO b -> TransactionIO a
forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
forall a b.
TransactionIO (a -> b) -> TransactionIO a -> TransactionIO b
forall a b c.
(a -> b -> c)
-> TransactionIO a -> TransactionIO b -> TransactionIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> TransactionIO a
pure :: forall a. a -> TransactionIO a
$c<*> :: forall a b.
TransactionIO (a -> b) -> TransactionIO a -> TransactionIO b
<*> :: forall a b.
TransactionIO (a -> b) -> TransactionIO a -> TransactionIO b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> TransactionIO a -> TransactionIO b -> TransactionIO c
liftA2 :: forall a b c.
(a -> b -> c)
-> TransactionIO a -> TransactionIO b -> TransactionIO c
$c*> :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
*> :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
$c<* :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO a
<* :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO a
Applicative, Applicative TransactionIO
Applicative TransactionIO =>
(forall a b.
 TransactionIO a -> (a -> TransactionIO b) -> TransactionIO b)
-> (forall a b.
    TransactionIO a -> TransactionIO b -> TransactionIO b)
-> (forall a. a -> TransactionIO a)
-> Monad TransactionIO
forall a. a -> TransactionIO a
forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
forall a b.
TransactionIO a -> (a -> TransactionIO b) -> TransactionIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
TransactionIO a -> (a -> TransactionIO b) -> TransactionIO b
>>= :: forall a b.
TransactionIO a -> (a -> TransactionIO b) -> TransactionIO b
$c>> :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
>> :: forall a b. TransactionIO a -> TransactionIO b -> TransactionIO b
$creturn :: forall a. a -> TransactionIO a
return :: forall a. a -> TransactionIO a
Monad, Monad TransactionIO
Monad TransactionIO =>
(forall a. IO a -> TransactionIO a) -> MonadIO TransactionIO
forall a. IO a -> TransactionIO a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> TransactionIO a
liftIO :: forall a. IO a -> TransactionIO a
MonadIO, MonadError QueryError, MonadIO TransactionIO
MonadIO TransactionIO =>
(forall b.
 ((forall a. TransactionIO a -> IO a) -> IO b) -> TransactionIO b)
-> MonadUnliftIO TransactionIO
forall b.
((forall a. TransactionIO a -> IO a) -> IO b) -> TransactionIO b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b.
((forall a. TransactionIO a -> IO a) -> IO b) -> TransactionIO b
withRunInIO :: forall b.
((forall a. TransactionIO a -> IO a) -> IO b) -> TransactionIO b
MonadUnliftIO, Monad TransactionIO
Monad TransactionIO =>
(forall e a. (HasCallStack, Exception e) => e -> TransactionIO a)
-> MonadThrow TransactionIO
forall e a. (HasCallStack, Exception e) => e -> TransactionIO a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> TransactionIO a
throwM :: forall e a. (HasCallStack, Exception e) => e -> TransactionIO a
MonadThrow)

data Transaction = Transaction

instance Semigroup a => Semigroup (TransactionIO a) where
  <> :: TransactionIO a -> TransactionIO a -> TransactionIO a
(<>) = (a -> a -> a)
-> TransactionIO a -> TransactionIO a -> TransactionIO a
forall a b c.
(a -> b -> c)
-> TransactionIO a -> TransactionIO b -> TransactionIO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (TransactionIO a) where
  mempty :: TransactionIO a
mempty = a -> TransactionIO a
forall a. a -> TransactionIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

run :: TransactionIO a -> IsolationLevel -> Mode -> Deferrable -> Bool -> Session a
run :: forall a.
TransactionIO a
-> IsolationLevel -> Mode -> Deferrable -> Bool -> Session a
run (TransactionIO ReaderT Transaction Session a
txio) IsolationLevel
isolation Mode
mode Deferrable
deferrable Bool
preparable = ResourceT Session a -> Session a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT Session a -> Session a)
-> ResourceT Session a -> Session a
forall a b. (a -> b) -> a -> b
$ do
  UnliftIO forall a. Session a -> IO a
runInIO <- Session (UnliftIO Session) -> ResourceT Session (UnliftIO Session)
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Session (UnliftIO Session)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  let acq :: Acquire Transaction
acq = IO Transaction
-> (Transaction -> ReleaseType -> IO ()) -> Acquire Transaction
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType (Session Transaction -> IO Transaction
forall a. Session a -> IO a
runInIO (Session Transaction -> IO Transaction)
-> Session Transaction -> IO Transaction
forall a b. (a -> b) -> a -> b
$ IsolationLevel -> Mode -> Deferrable -> Bool -> Session Transaction
startTransaction IsolationLevel
isolation Mode
mode Deferrable
deferrable Bool
preparable) ((Session () -> IO ()
forall a. Session a -> IO a
runInIO (Session () -> IO ())
-> (ReleaseType -> Session ()) -> ReleaseType -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ReleaseType -> Session ()) -> ReleaseType -> IO ())
-> (Transaction -> ReleaseType -> Session ())
-> Transaction
-> ReleaseType
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Transaction -> ReleaseType -> Session ()
endTransaction Bool
preparable)
  (ReleaseKey
_, Transaction
tx) <- Acquire Transaction -> ResourceT Session (ReleaseKey, Transaction)
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire Acquire Transaction
acq
  Session a -> ResourceT Session a
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Session a -> ResourceT Session a)
-> Session a -> ResourceT Session a
forall a b. (a -> b) -> a -> b
$ ReaderT Transaction Session a -> Transaction -> Session a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Transaction Session a
txio Transaction
tx

-- | Like `Session.sql` but in a `TransactionIO`. It should not attempt any statements that cannot be safely run inside a transaction.
sql :: ByteString -> TransactionIO ()
sql :: ByteString -> TransactionIO ()
sql = ReaderT Transaction Session () -> TransactionIO ()
forall a. ReaderT Transaction Session a -> TransactionIO a
TransactionIO (ReaderT Transaction Session () -> TransactionIO ())
-> (ByteString -> ReaderT Transaction Session ())
-> ByteString
-> TransactionIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session () -> ReaderT Transaction Session ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Transaction m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Session () -> ReaderT Transaction Session ())
-> (ByteString -> Session ())
-> ByteString
-> ReaderT Transaction Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Session ()
Session.sql

-- | Like `Session.statement` but in a `TransactionIO`. It should not attempt any statements that cannot be safely run inside a transaction.
statement :: params -> Statement params result -> TransactionIO result
statement :: forall params result.
params -> Statement params result -> TransactionIO result
statement params
params Statement params result
stmt = ReaderT Transaction Session result -> TransactionIO result
forall a. ReaderT Transaction Session a -> TransactionIO a
TransactionIO (ReaderT Transaction Session result -> TransactionIO result)
-> (Session result -> ReaderT Transaction Session result)
-> Session result
-> TransactionIO result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session result -> ReaderT Transaction Session result
forall (m :: * -> *) a. Monad m => m a -> ReaderT Transaction m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Session result -> TransactionIO result)
-> Session result -> TransactionIO result
forall a b. (a -> b) -> a -> b
$ params -> Statement params result -> Session result
forall params result.
params -> Statement params result -> Session result
Session.statement params
params Statement params result
stmt

startTransaction :: IsolationLevel -> Mode -> Deferrable -> Bool -> Session Transaction
startTransaction :: IsolationLevel -> Mode -> Deferrable -> Bool -> Session Transaction
startTransaction IsolationLevel
isolation Mode
mode Deferrable
deferrable Bool
prepare = do
  () -> Statement () () -> Session ()
forall params result.
params -> Statement params result -> Session result
Session.statement () (IsolationLevel -> Mode -> Deferrable -> Bool -> Statement () ()
Statements.startTransaction IsolationLevel
isolation Mode
mode Deferrable
deferrable Bool
prepare)
  Transaction -> Session Transaction
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transaction
Transaction

endTransaction :: Bool -> Transaction -> ReleaseType -> Session ()
endTransaction :: Bool -> Transaction -> ReleaseType -> Session ()
endTransaction Bool
prepare Transaction
tx = \case
  ReleaseType
ReleaseEarly     -> Bool -> Transaction -> Session ()
commitTransaction Bool
prepare Transaction
tx
  ReleaseType
ReleaseNormal    -> Bool -> Transaction -> Session ()
commitTransaction Bool
prepare Transaction
tx
  ReleaseType
ReleaseException -> Bool -> Transaction -> Session ()
rollbackTransaction Bool
prepare Transaction
tx

commitTransaction :: Bool -> Transaction -> Session ()
commitTransaction :: Bool -> Transaction -> Session ()
commitTransaction Bool
prepare Transaction
Transaction = do
  () -> Statement () () -> Session ()
forall params result.
params -> Statement params result -> Session result
Session.statement () (Bool -> Statement () ()
Statements.commitTransaction Bool
prepare)

rollbackTransaction :: Bool -> Transaction -> Session ()
rollbackTransaction :: Bool -> Transaction -> Session ()
rollbackTransaction Bool
prepare Transaction
Transaction = do
  () -> Statement () () -> Session ()
forall params result.
params -> Statement params result -> Session result
Session.statement () (Bool -> Statement () ()
Statements.rollbackTransaction Bool
prepare)



data CondemnTransactionException = CondemnTransactionException
  deriving (Int -> CondemnTransactionException -> ShowS
[CondemnTransactionException] -> ShowS
CondemnTransactionException -> String
(Int -> CondemnTransactionException -> ShowS)
-> (CondemnTransactionException -> String)
-> ([CondemnTransactionException] -> ShowS)
-> Show CondemnTransactionException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CondemnTransactionException -> ShowS
showsPrec :: Int -> CondemnTransactionException -> ShowS
$cshow :: CondemnTransactionException -> String
show :: CondemnTransactionException -> String
$cshowList :: [CondemnTransactionException] -> ShowS
showList :: [CondemnTransactionException] -> ShowS
Show)

instance Exception CondemnTransactionException

-- | Throw an internal exception that causes the transaction to be rolled back. If you wish to rollback a transaction with a more useful exception use `throwIO`
condemn :: TransactionIO a
condemn :: forall a. TransactionIO a
condemn = CondemnTransactionException -> TransactionIO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO CondemnTransactionException
CondemnTransactionException