diff --git a/conflicts-test/Main.hs b/conflicts-test/Main.hs --- a/conflicts-test/Main.hs +++ b/conflicts-test/Main.hs @@ -1,9 +1,10 @@ module Main where -import Prelude +import Rebase.Prelude import qualified Hasql.Connection as A import qualified Hasql.Session as B import qualified Hasql.Transaction as C +import qualified Hasql.Transaction.Sessions as G import qualified Main.Statements as D import qualified Main.Transactions as E import qualified Control.Concurrent.Async as F @@ -24,13 +25,13 @@ A.settings "localhost" 5432 "postgres" "" "postgres" release (connection1, connection2) = do - transact connection1 E.dropSchema + transaction connection1 E.dropSchema A.release connection1 A.release connection2 use (connection1, connection2) = do - try (transact connection1 E.dropSchema) :: IO (Either SomeException ()) - transact connection1 E.createSchema + try (transaction connection1 E.dropSchema) :: IO (Either SomeException ()) + transaction connection1 E.createSchema success <- fmap and (traverse runTest tests) if success then exitSuccess @@ -46,8 +47,8 @@ B.run session connection >>= either (fail . show) return -transact connection transaction = - session connection (C.transact transaction) +transaction connection transaction = + session connection (G.transaction G.RepeatableRead G.Write transaction) type Test = @@ -58,8 +59,8 @@ do id1 <- session connection1 (B.statement 0 D.createAccount) id2 <- session connection1 (B.statement 0 D.createAccount) - async1 <- F.async (replicateM_ 1000 (transact connection1 (E.transfer id1 id2 1))) - async2 <- F.async (replicateM_ 1000 (transact connection2 (E.transfer id1 id2 1))) + async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transaction connection2 (E.transfer id1 id2 1))) F.wait async1 F.wait async2 balance1 <- session connection1 (B.statement id1 D.getBalance) @@ -73,8 +74,8 @@ do id1 <- session connection1 (B.statement 0 D.createAccount) id2 <- session connection1 (B.statement 0 D.createAccount) - async1 <- F.async (replicateM_ 1000 (transact connection1 (E.transfer id1 id2 1))) - async2 <- F.async (replicateM_ 1000 (transact connection2 (E.getBalance id1))) + async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transaction connection2 (C.statement id1 D.getBalance))) F.wait async1 F.wait async2 balance1 <- session connection1 (B.statement id1 D.getBalance) @@ -88,7 +89,7 @@ do id1 <- session connection1 (B.statement 0 D.createAccount) id2 <- session connection1 (B.statement 0 D.createAccount) - async1 <- F.async (transact connection1 (E.transferTimes 200 id1 id2 1)) + async1 <- F.async (transaction connection1 (E.transferTimes 200 id1 id2 1)) async2 <- F.async (session connection2 (replicateM_ 200 (B.statement (id1, 1) D.modifyBalance))) F.wait async1 F.wait async2 diff --git a/conflicts-test/Main/Statements.hs b/conflicts-test/Main/Statements.hs --- a/conflicts-test/Main/Statements.hs +++ b/conflicts-test/Main/Statements.hs @@ -1,6 +1,6 @@ module Main.Statements where -import Prelude +import Rebase.Prelude import Hasql.Statement import qualified Hasql.Encoders as E import qualified Hasql.Decoders as D diff --git a/conflicts-test/Main/Transactions.hs b/conflicts-test/Main/Transactions.hs --- a/conflicts-test/Main/Transactions.hs +++ b/conflicts-test/Main/Transactions.hs @@ -1,25 +1,30 @@ module Main.Transactions where -import Prelude +import Rebase.Prelude import Hasql.Transaction import qualified Main.Statements as A createSchema :: Transaction () -createSchema = statement Write Serializable A.createAccountTable () +createSchema = + do + statement () A.createAccountTable dropSchema :: Transaction () -dropSchema = statement Write Serializable A.dropAccountTable () +dropSchema = + do + statement () A.dropAccountTable transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool -transfer id1 id2 amount = do - ifS - (statement Write Serializable A.modifyBalance (id1, amount)) - (statement Write Serializable A.modifyBalance (id2, negate amount)) - (pure False) +transfer id1 id2 amount = + do + success <- statement (id1, amount) A.modifyBalance + if success + then + statement (id2, negate amount) A.modifyBalance + else + return False transferTimes :: Int -> Int64 -> Int64 -> Scientific -> Transaction () -transferTimes times id1 id2 amount = replicateM_ times (transfer id1 id2 amount) - -getBalance :: Int64 -> Transaction (Maybe Scientific) -getBalance id = statement Read ReadCommitted A.getBalance id +transferTimes times id1 id2 amount = + replicateM_ times (transfer id1 id2 amount) diff --git a/hasql-transaction.cabal b/hasql-transaction.cabal --- a/hasql-transaction.cabal +++ b/hasql-transaction.cabal @@ -1,7 +1,7 @@ name: hasql-transaction -version: 0.10.0.3 +version: 1 category: Hasql, Database, PostgreSQL -synopsis: Composable abstraction over retryable transactions for Hasql +synopsis: A composable abstraction over the retryable transactions for Hasql homepage: https://github.com/nikita-volkov/hasql-transaction bug-reports: https://github.com/nikita-volkov/hasql-transaction/issues author: Nikita Volkov @@ -22,24 +22,23 @@ default-language: Haskell2010 exposed-modules: Hasql.Transaction - other-modules: - Hasql.Transaction.Builders - Hasql.Transaction.Prelude Hasql.Transaction.Sessions - Hasql.Transaction.Statements - Hasql.Transaction.Types + other-modules: + Hasql.Transaction.Private.Prelude + Hasql.Transaction.Private.Model + Hasql.Transaction.Private.SQL + Hasql.Transaction.Private.Statements + Hasql.Transaction.Private.Sessions + Hasql.Transaction.Private.Transaction build-depends: base >=4.9 && <5, bytestring >=0.10 && <0.11, - bytestring-strict-builder >=0.4.5.3 && <0.5, + bytestring-tree-builder >=0.1 && <0.3, contravariant >=1.3 && <2, contravariant-extras >=0.3 && <0.4, hasql >=1.4 && <1.5, mtl >=2 && <3, - profunctors >=5 && <6, - transformers >=0.3 && <0.6, - selective >=0.4 && <0.5, - semigroupoids >=5.3.2 && <6 + transformers >=0.3 && <0.6 test-suite conflicts-test type: exitcode-stdio-1.0 @@ -55,7 +54,7 @@ -threaded "-with-rtsopts=-N" build-depends: - async >=2.1 && <3, hasql-transaction, hasql, - rerebase >=1.4 && <2 + async >=2.1 && <3, + rebase <2 diff --git a/library/Hasql/Transaction.hs b/library/Hasql/Transaction.hs --- a/library/Hasql/Transaction.hs +++ b/library/Hasql/Transaction.hs @@ -1,150 +1,14 @@ -{-| -DSL for composition of transactions with automated conflict resolution. --} +-- | +-- An API for declaration of transactions. module Hasql.Transaction ( - {-* Sessions -} - transact, - {-* Transaction -} + -- * Transaction monad Transaction, - statement, - sql, - session, condemn, - restrict, - {-* Settings -} - Mode(..), - Level(..), - {-* Reexports -} - {-| - This module also reexports the following types for you to require lesser imports: - - * `Reexports.Session` - * `Reexports.Statement` - -} - module Reexports, + sql, + statement, ) where -import Hasql.Transaction.Prelude -import Hasql.Transaction.Types -import qualified Hasql.Session as Reexports (Session) -import qualified Hasql.Statement as Reexports (Statement) -import qualified Hasql.Session as Session -import qualified Hasql.Statement as Statement -import qualified Hasql.Transaction.Sessions as Sessions - - -{-| -Execute transaction in session. --} -transact :: Transaction a -> Session.Session a -transact (Transaction mode level list) = - Sessions.inAlternatingTransaction mode level $ - fmap (flip runStateT Uncondemned) list - - -{-| -Composable transaction providing for automated conflict resolution. - -Mode and level is associated with the transaction, -which makes them participate in composition. -In a composed transaction they become the strictest of the ones -associated with the transactions that constitute it. -This allows you to safely compose transactions with different -ACID guarantees. - -It cannot have an instance of Monad, -because it makes it impossible to implement composition of -mode and level associated with constituent transactions. -It still however is possible to compose transactions -in such a way that the result of a transaction is used -to decide which transaction to execute next, -thanks to the recently discovered `Selective` interface. - -Supports alternative branching, -where the alternative gets executed in case of a transaction conflict. --} -data Transaction a = Transaction Mode Level [StateT Condemnation Session.Session a] - -deriving instance Functor Transaction - -instance Applicative Transaction where - pure = Transaction minBound minBound . pure . pure - (<*>) (Transaction mode1 level1 list1) (Transaction mode2 level2 list2) = - Transaction (max mode1 mode2) (max level1 level2) ((<*>) <$> list1 <*> list2) - -instance Selective Transaction where - select (Transaction mode1 level1 list1) (Transaction mode2 level2 list2) = - Transaction (max mode1 mode2) (max level1 level2) (select <$> list1 <*> list2) - -instance Alt Transaction where - () (Transaction mode1 level1 list1) (Transaction mode2 level2 list2) = - Transaction (max mode1 mode2) (max level1 level2) (list1 <> list2) - -{-| -Execute a single statement under mode and level. - -__Warning:__ The statement must not be transaction-related -like @BEGIN@, @COMMIT@ or @ABORT@, otherwise you'll break the abstraction. --} -statement :: Mode -> Level -> Statement.Statement i o -> i -> Transaction o -statement mode level statement i = session mode level $ Session.statement i statement - -{-| -Execute a possibly multistatement SQL string under a mode and level. -SQL strings cannot be dynamically parameterized or produce a result. - -__Warning:__ SQL must not be transaction-related -like @BEGIN@, @COMMIT@ or @ABORT@, otherwise you'll break the abstraction. --} -sql :: Mode -> Level -> ByteString -> Transaction () -sql mode level sql = session mode level $ Session.sql sql - -{-| -Execute a composition of statements under the same mode and level. - -__Warning:__ - -1. You must know that it is possible to break the abstraction, -if you execute statements such as @BEGIN@ inside of the session. - -1. For the same reason you cannot execute other transactions inside of that session. - -1. You must beware that in case of conflicts any IO code that you may lift -into session will get executed multiple times. -This is the way the automatic conflict resolution works: -the transaction gets retried, when a conflict arises. -So be cautious about doing any mutations or rocket launches in that IO! -Simply pinging for things such as current time is totally fine though. -Still it's not recommended because it's often a symptom of bad application design. - -Due to the mentioned it's highly advised to keep all the session code -inside of the definition of a transaction. -Thus you'll be guaranteed to have control over what's going on inside of the -executed session and it will not be possible for this code -to be affected by any outside changes or used elsewhere. --} -session :: Mode -> Level -> Session.Session a -> Transaction a -session mode level session = Transaction mode level [lift session] - -{-| -Cause transaction to eventually roll back. - -This allows to perform some transactional actions, -collecting their results, and decide, -whether to commit the introduced changes to the DB -based on those results, -as well as emit those results outside of the transaction. --} -condemn :: Transaction () -condemn = Transaction minBound minBound [put Condemned] - -{-| -Restrict the transaction isolation level. - -Will pick up the strictest level among the one you've specified and -the one already associated with the transaction being updated. --} -restrict :: Level -> Transaction a -> Transaction a -restrict newLevel (Transaction mode oldLevel sessions) = Transaction mode (max newLevel oldLevel) sessions +import Hasql.Transaction.Private.Transaction +import Hasql.Transaction.Private.Model diff --git a/library/Hasql/Transaction/Builders.hs b/library/Hasql/Transaction/Builders.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Builders.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Hasql.Transaction.Builders -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Types -import ByteString.StrictBuilder - - -beginTransaction :: Mode -> Level -> Builder -beginTransaction mode_ level_ = - "begin " <> level level_ <> " " <> mode mode_ - -level :: Level -> Builder -level = \ case - ReadCommitted -> "isolation level read committed" - RepeatableRead -> "isolation level repeatable read" - Serializable -> "isolation level serializable" - -mode :: Mode -> Builder -mode = \ case - Write -> "read write" - Read -> "read only" diff --git a/library/Hasql/Transaction/Prelude.hs b/library/Hasql/Transaction/Prelude.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Prelude.hs +++ /dev/null @@ -1,127 +0,0 @@ -module Hasql.Transaction.Prelude -( - module Exports, - tryError, -) -where - - --- base -------------------------- -import Control.Applicative as Exports -import Control.Arrow as Exports -import Control.Category as Exports -import Control.Concurrent as Exports -import Control.Exception as Exports -import Control.Monad as Exports hiding (join, fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM) -import Control.Monad.IO.Class as Exports -import Control.Monad.Fail as Exports -import Control.Monad.Fix as Exports hiding (fix) -import Control.Monad.ST as Exports -import Data.Bits as Exports -import Data.Bool as Exports -import Data.Char as Exports -import Data.Coerce as Exports -import Data.Complex as Exports -import Data.Data as Exports -import Data.Dynamic as Exports -import Data.Either as Exports -import Data.Fixed as Exports -import Data.Foldable as Exports hiding (toList) -import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports -import Data.Functor.Identity as Exports -import Data.Int as Exports -import Data.IORef as Exports -import Data.Ix as Exports -import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') -import Data.Maybe as Exports -import Data.Monoid as Exports hiding (Last(..), First(..), (<>), Alt) -import Data.Ord as Exports -import Data.Proxy as Exports -import Data.Ratio as Exports -import Data.Semigroup as Exports -import Data.STRef as Exports -import Data.String as Exports -import Data.Traversable as Exports -import Data.Tuple as Exports -import Data.Unique as Exports -import Data.Version as Exports -import Data.Word as Exports -import Debug.Trace as Exports -import Foreign.ForeignPtr as Exports -import Foreign.Ptr as Exports -import Foreign.StablePtr as Exports -import Foreign.Storable as Exports hiding (sizeOf, alignment) -import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) -import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..)) -import GHC.Generics as Exports (Generic, Generic1) -import GHC.IO.Exception as Exports -import Numeric as Exports -import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) -import System.Environment as Exports -import System.Exit as Exports -import System.IO as Exports -import System.IO.Error as Exports -import System.IO.Unsafe as Exports -import System.Mem as Exports -import System.Mem.StableName as Exports -import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) -import Text.Printf as Exports (printf, hPrintf) -import Text.Read as Exports (Read(..), readMaybe, readEither) -import Unsafe.Coerce as Exports - --- selective -------------------------- -import Control.Selective as Exports - --- transformers -------------------------- -import Control.Monad.IO.Class as Exports -import Control.Monad.Trans.Class as Exports -import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) -import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) -import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) - --- semigroupoids -------------------------- -import Data.Bifunctor.Apply as Exports hiding (first, second) -import Data.Functor.Alt as Exports hiding (($>), many, some, optional) -import Data.Functor.Apply as Exports hiding (($>)) -import Data.Functor.Bind as Exports hiding (join, ($>)) -import Data.Functor.Extend as Exports -import Data.Functor.Plus as Exports hiding (($>), some, many, optional) -import Data.Semigroup.Bifoldable as Exports -import Data.Semigroup.Bitraversable as Exports -import Data.Semigroup.Foldable as Exports -import Data.Semigroup.Traversable as Exports -import Data.Semigroupoid as Exports (Semigroupoid(..)) - --- mtl -------------------------- -import Control.Monad.Error.Class as Exports (MonadError (..)) - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports -import Data.Profunctor.Choice as Exports -import Data.Profunctor.Strong as Exports - --- contravariant -------------------------- -import Data.Functor.Contravariant as Exports -import Data.Functor.Contravariant.Divisible as Exports - --- contravariant-extras -------------------------- -import Contravariant.Extras as Exports - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - -tryError :: MonadError e m => m a -> m (Either e a) -tryError m = - catchError (liftM Right m) (return . Left) diff --git a/library/Hasql/Transaction/Private/Model.hs b/library/Hasql/Transaction/Private/Model.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/Model.hs @@ -0,0 +1,25 @@ +module Hasql.Transaction.Private.Model +where + +import Hasql.Transaction.Private.Prelude + +-- | +-- +data Mode = + -- | + -- Read-only. No writes possible. + Read | + -- | + -- Write and commit. + Write + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | +-- For reference see +-- . +-- +data IsolationLevel = + ReadCommitted | + RepeatableRead | + Serializable + deriving (Show, Eq, Ord, Enum, Bounded) diff --git a/library/Hasql/Transaction/Private/Prelude.hs b/library/Hasql/Transaction/Private/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/Prelude.hs @@ -0,0 +1,103 @@ +module Hasql.Transaction.Private.Prelude +( + module Exports, + tryError, +) +where + + +-- base +------------------------- +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (join, fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.IO.Class as Exports +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Last(..), First(..), (<>), Alt) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Semigroup as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (sizeOf, alignment) +import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) +import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..)) +import GHC.Generics as Exports (Generic, Generic1) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (printf, hPrintf) +import Text.Read as Exports (Read(..), readMaybe, readEither) +import Unsafe.Coerce as Exports + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) + +-- mtl +------------------------- +import Control.Monad.Error.Class as Exports (MonadError (..)) + +-- contravariant +------------------------- +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports + +-- contravariant-extras +------------------------- +import Contravariant.Extras as Exports + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +tryError :: MonadError e m => m a -> m (Either e a) +tryError m = + catchError (liftM Right m) (return . Left) diff --git a/library/Hasql/Transaction/Private/SQL.hs b/library/Hasql/Transaction/Private/SQL.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/SQL.hs @@ -0,0 +1,29 @@ +module Hasql.Transaction.Private.SQL +where + +import Hasql.Transaction.Private.Prelude +import Hasql.Transaction.Private.Model +import qualified ByteString.TreeBuilder as D + + +beginTransaction :: IsolationLevel -> Mode -> ByteString +beginTransaction isolation mode = + D.toByteString builder + where + builder = + "BEGIN " <> isolationBuilder <> " " <> modeBuilder + where + isolationBuilder = + case isolation of + ReadCommitted -> "ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ" + Serializable -> "ISOLATION LEVEL SERIALIZABLE" + modeBuilder = + case mode of + Write -> "READ WRITE" + Read -> "READ ONLY" + +declareCursor :: ByteString -> ByteString -> ByteString +declareCursor name sql = + D.toByteString $ + "DECLARE " <> D.byteString name <> " NO SCROLL CURSOR FOR " <> D.byteString sql diff --git a/library/Hasql/Transaction/Private/Sessions.hs b/library/Hasql/Transaction/Private/Sessions.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/Sessions.hs @@ -0,0 +1,34 @@ +module Hasql.Transaction.Private.Sessions +where + +import Hasql.Transaction.Private.Prelude +import Hasql.Transaction.Private.Model +import qualified Hasql.Session as A +import qualified Hasql.Transaction.Private.Statements as B + + +{- +We may want to +do one transaction retry in case of the 23505 error, and fail if an identical +error is seen. +-} +inRetryingTransaction :: IsolationLevel -> Mode -> A.Session (a, Bool) -> A.Session a +inRetryingTransaction isolation mode session = + fix $ \recur -> catchError normal (onError recur) + where + normal = + do + A.statement () (B.beginTransaction isolation mode) + (result, commit) <- session + if commit + then A.statement () B.commitTransaction + else A.statement () B.abortTransaction + return result + onError continue error = + do + A.statement () B.abortTransaction + case error of + A.QueryError _ _ (A.ResultError (A.ServerError "40001" _ _ _)) -> + continue + _ -> + throwError error diff --git a/library/Hasql/Transaction/Private/Statements.hs b/library/Hasql/Transaction/Private/Statements.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/Statements.hs @@ -0,0 +1,50 @@ +module Hasql.Transaction.Private.Statements +where + +import Hasql.Transaction.Private.Prelude +import Hasql.Transaction.Private.Model +import qualified Hasql.Statement as A +import qualified Hasql.Encoders as B +import qualified Hasql.Decoders as C +import qualified Hasql.Transaction.Private.SQL as D + + +-- * Transactions +------------------------- + +beginTransaction :: IsolationLevel -> Mode -> A.Statement () () +beginTransaction isolation mode = + A.Statement (D.beginTransaction isolation mode) B.noParams C.noResult True + +commitTransaction :: A.Statement () () +commitTransaction = + A.Statement "COMMIT" B.noParams C.noResult True + +abortTransaction :: A.Statement () () +abortTransaction = + A.Statement "ABORT" B.noParams C.noResult True + + +-- * Streaming +------------------------- + +declareCursor :: ByteString -> ByteString -> B.Params a -> A.Statement a () +declareCursor name sql encoder = + A.Statement (D.declareCursor name sql) encoder C.noResult False + +closeCursor :: A.Statement ByteString () +closeCursor = + A.Statement "CLOSE $1" ((B.param . B.nonNullable) B.bytea) C.noResult True + +fetchFromCursor :: (b -> a -> b) -> b -> C.Row a -> A.Statement (Int64, ByteString) b +fetchFromCursor step init rowDec = + A.Statement sql encoder decoder True + where + sql = + "FETCH FORWARD $1 FROM $2" + encoder = + contrazip2 + ((B.param . B.nonNullable) B.int8) + ((B.param . B.nonNullable) B.bytea) + decoder = + C.foldlRows step init rowDec diff --git a/library/Hasql/Transaction/Private/Transaction.hs b/library/Hasql/Transaction/Private/Transaction.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Private/Transaction.hs @@ -0,0 +1,57 @@ +module Hasql.Transaction.Private.Transaction +where + +import Hasql.Transaction.Private.Prelude +import Hasql.Transaction.Private.Model +import qualified Hasql.Statement as A +import qualified Hasql.Session as B +import qualified Hasql.Transaction.Private.Statements as C +import qualified Hasql.Transaction.Private.Sessions as D + + +-- | +-- A composable abstraction over the retryable transactions. +-- +-- Executes multiple queries under the specified mode and isolation level, +-- while automatically retrying the transaction in case of conflicts. +-- Thus this abstraction closely reproduces the behaviour of 'STM'. +newtype Transaction a = + Transaction (StateT Bool B.Session a) + deriving (Functor, Applicative, Monad) + +instance Semigroup a => Semigroup (Transaction a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Transaction a) where + mempty = pure mempty + mappend = liftA2 mappend + +-- | +-- Execute the transaction using the provided isolation level and mode. +{-# INLINE run #-} +run :: Transaction a -> IsolationLevel -> Mode -> B.Session a +run (Transaction session) isolation mode = + D.inRetryingTransaction isolation mode (runStateT session True) + +-- | +-- Possibly a multi-statement query, +-- which however cannot be parameterized or prepared, +-- nor can any results of it be collected. +{-# INLINE sql #-} +sql :: ByteString -> Transaction () +sql = + Transaction . lift . B.sql + +-- | +-- Parameters and a specification of the parametric query to apply them to. +{-# INLINE statement #-} +statement :: a -> A.Statement a b -> Transaction b +statement params statement = + Transaction . lift $ B.statement params statement + +-- | +-- Cause transaction to eventually roll back. +{-# INLINE condemn #-} +condemn :: Transaction () +condemn = + Transaction $ put False diff --git a/library/Hasql/Transaction/Sessions.hs b/library/Hasql/Transaction/Sessions.hs --- a/library/Hasql/Transaction/Sessions.hs +++ b/library/Hasql/Transaction/Sessions.hs @@ -1,47 +1,20 @@ -{-| - -TODO: -We may want to -do one transaction retry in case of the 23505 error, and fail if an identical -error is seen. --} module Hasql.Transaction.Sessions +( + transaction, + -- * Transaction settings + C.Mode(..), + C.IsolationLevel(..), +) where -import Hasql.Transaction.Prelude -import Hasql.Transaction.Types -import Hasql.Session -import qualified Hasql.Transaction.Statements as Statements +import qualified Hasql.Transaction.Private.Transaction as A +import qualified Hasql.Session as B +import qualified Hasql.Transaction.Private.Model as C -inAlternatingTransaction :: Mode -> Level -> [Session (a, Condemnation)] -> Session a -inAlternatingTransaction mode level sessions = - let - loop = \ case - session : sessionsTail -> tryTransaction mode level session >>= \ case - Just a -> return a - Nothing -> loop sessionsTail - _ -> loop sessions - in loop sessions - -tryTransaction :: Mode -> Level -> Session (a, Condemnation) -> Session (Maybe a) -tryTransaction mode level body = do - - statement () (Statements.beginTransaction mode level) - - bodyRes <- catchError (fmap Just body) $ \ error -> do - statement () Statements.abortTransaction - handleTransactionError error $ return Nothing - - case bodyRes of - Just (res, commit) -> catchError (commitOrAbort commit $> Just res) $ \ error -> do - handleTransactionError error $ return Nothing - Nothing -> return Nothing - -commitOrAbort = \ case - Uncondemned -> statement () Statements.commitTransaction - Condemned -> statement () Statements.abortTransaction - -handleTransactionError error onTransactionError = case error of - QueryError _ _ (ResultError (ServerError "40001" _ _ _)) -> onTransactionError - error -> throwError error +-- | +-- Execute the transaction using the provided isolation level and mode. +{-# INLINE transaction #-} +transaction :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a +transaction isolation mode transaction = + A.run transaction isolation mode diff --git a/library/Hasql/Transaction/Statements.hs b/library/Hasql/Transaction/Statements.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Statements.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Hasql.Transaction.Statements -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Types -import Hasql.Statement -import qualified ByteString.StrictBuilder as Builder -import qualified Hasql.Encoders as B -import qualified Hasql.Decoders as C -import qualified Hasql.Transaction.Builders as Builders - - -beginTransaction :: Mode -> Level -> Statement () () -beginTransaction mode level = - Statement (Builder.builderBytes (Builders.beginTransaction mode level)) B.noParams C.noResult True - -commitTransaction :: Statement () () -commitTransaction = - Statement "commit" B.noParams C.noResult True - -abortTransaction :: Statement () () -abortTransaction = - Statement "abort" B.noParams C.noResult True diff --git a/library/Hasql/Transaction/Types.hs b/library/Hasql/Transaction/Types.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Types.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Hasql.Transaction.Types -where - -import Hasql.Transaction.Prelude - - -{-| -Execution mode: either read or write. --} -data Mode = - {-| - Read-only. No writes possible. - -} - Read | - {-| - Write and commit. - -} - Write - deriving (Show, Eq, Ord, Enum, Bounded) - -{-| -Transaction isolation level. - -For reference see -. --} -data Level = - ReadCommitted | - RepeatableRead | - Serializable - deriving (Show, Eq, Ord, Enum, Bounded) - -data Condemnation = - Condemned | - Uncondemned - deriving (Show, Eq, Ord, Enum, Bounded)