mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 17:31:56 +03:00
16b09f7d52
https://github.com/hasura/graphql-engine-mono/pull/2268 GitOrigin-RevId: b1bc2812cd403688228b3ecf143aa36b3a6af707
100 lines
2.8 KiB
Haskell
100 lines
2.8 KiB
Haskell
module Database.MSSQL.Transaction
|
|
( runTx
|
|
, unitQ
|
|
, withQ
|
|
, TxT
|
|
, TxET(..)
|
|
, MSSQLTxError(..)
|
|
, ResultOk(..)
|
|
) where
|
|
|
|
import Hasura.Prelude (hoistEither)
|
|
import Prelude
|
|
|
|
import qualified Database.ODBC.SQLServer as ODBC
|
|
|
|
import Control.Exception (try)
|
|
import Control.Monad (void)
|
|
import Control.Monad.Except (ExceptT (..), MonadError, catchError, throwError,
|
|
withExceptT)
|
|
import Control.Monad.IO.Class (MonadIO (..))
|
|
import Control.Monad.Morph (hoist)
|
|
import Control.Monad.Reader (MonadFix, MonadReader, ReaderT (..))
|
|
|
|
|
|
data MSSQLTxError
|
|
= MSSQLTxError !ODBC.Query !ODBC.ODBCException
|
|
deriving (Eq, Show)
|
|
|
|
newtype ResultOk = ResultOk [[ODBC.Value]]
|
|
deriving (Eq, Show)
|
|
|
|
-- | The transaction command to run, parameterised over:
|
|
-- e - the exception type
|
|
-- m - some Monad
|
|
-- a - the successful result type
|
|
newtype TxET e m a
|
|
= TxET { txHandler :: ReaderT ODBC.Connection (ExceptT e m) a }
|
|
deriving (Functor, Applicative, Monad, MonadError e, MonadIO, MonadReader ODBC.Connection, MonadFix)
|
|
|
|
-- | The transaction command to run,
|
|
-- returning an MSSQLTxError or the result
|
|
type TxT m a = TxET MSSQLTxError m a
|
|
|
|
beginTx :: MonadIO m => TxT m ()
|
|
beginTx =
|
|
unitQ "BEGIN TRANSACTION"
|
|
|
|
commitTx :: MonadIO m => TxT m ()
|
|
commitTx =
|
|
unitQ "COMMIT TRANSACTION"
|
|
|
|
rollbackTx :: MonadIO m => TxT m ()
|
|
rollbackTx =
|
|
unitQ "ROLLBACK TRANSACTION"
|
|
|
|
unitQ :: MonadIO m => ODBC.Query -> TxT m ()
|
|
unitQ = void <$> withQ
|
|
|
|
withQ :: MonadIO m => ODBC.Query -> TxT m ResultOk
|
|
withQ q = TxET $ ReaderT $ \conn ->
|
|
hoist liftIO $ execQuery conn q
|
|
|
|
execQuery
|
|
:: MonadIO m
|
|
=> ODBC.Connection
|
|
-> ODBC.Query
|
|
-> ExceptT MSSQLTxError m ResultOk
|
|
execQuery conn query = do
|
|
result :: Either ODBC.ODBCException [[ODBC.Value]] <- liftIO $ try $ ODBC.query conn query
|
|
withExceptT (MSSQLTxError query) $ hoistEither $ ResultOk <$> result
|
|
|
|
-- | Run a command on the given connection wrapped in a transaction.
|
|
runTx :: MonadIO m
|
|
=> TxT m ResultOk
|
|
-> ODBC.Connection
|
|
-> ExceptT MSSQLTxError m ResultOk
|
|
runTx tx =
|
|
asTransaction (\connRsrc -> execTx connRsrc tx)
|
|
|
|
{-# INLINE execTx #-}
|
|
execTx :: ODBC.Connection -> TxET e m a -> ExceptT e m a
|
|
execTx conn tx = runReaderT (txHandler tx) conn
|
|
|
|
asTransaction :: MonadIO m
|
|
=> (ODBC.Connection -> ExceptT MSSQLTxError m ResultOk)
|
|
-> ODBC.Connection
|
|
-> ExceptT MSSQLTxError m ResultOk
|
|
asTransaction f conn = do
|
|
-- Begin the transaction. If there is an err, do not rollback
|
|
_ <- execTx conn beginTx
|
|
-- Run the transaction and commit. If there is an err, rollback
|
|
flip catchError rollback $ do
|
|
result <- f conn
|
|
_ <- execTx conn commitTx
|
|
return result
|
|
where
|
|
rollback err = do
|
|
_ <- execTx conn rollbackTx
|
|
throwError err
|