packages feed

hasql-transaction 1.0.1.4 → 1.2.2

raw patch · 24 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# 1.2++- Removed the `unpreparedTransaction` session because the same effects can now be achieved via the connection settings in Hasql++# 1.1++- Add automatic retry on deadlock errors (code 40P01)
− conflicts-test/Main.hs 
@@ -1,100 +0,0 @@-module Main where--import qualified Control.Concurrent.Async as F-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 Prelude--main :: IO ()-main =-  bracket acquire release use-  where-    acquire =-      (,) <$> acquire <*> acquire-      where-        acquire =-          join-            $ fmap (either (fail . show) return)-            $ A.acquire connectionSettings-          where-            connectionSettings =-              A.settings "localhost" 5432 "postgres" "postgres" "postgres"-    release (connection1, connection2) =-      do-        transaction connection1 E.dropSchema-        A.release connection1-        A.release connection2-    use (connection1, connection2) =-      do-        try (transaction connection1 E.dropSchema) :: IO (Either SomeException ())-        transaction connection1 E.createSchema-        success <- fmap and (traverse runTest tests)-        if success-          then exitSuccess-          else exitFailure-      where-        runTest test =-          test connection1 connection2-        tests =-          [readAndWriteTransactionsTest, transactionsTest, transactionAndQueryTest]--session :: A.Connection -> B.Session a -> IO a-session connection session =-  B.run session connection-    >>= either (fail . show) return--transaction :: A.Connection -> C.Transaction a -> IO a-transaction connection transaction =-  session connection (G.transaction G.RepeatableRead G.Write transaction)--type Test =-  A.Connection -> A.Connection -> IO Bool--transactionsTest :: Test-transactionsTest connection1 connection2 =-  do-    id1 <- session connection1 (B.statement 0 D.createAccount)-    id2 <- session connection1 (B.statement 0 D.createAccount)-    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)-    balance2 <- session connection1 (B.statement id2 D.getBalance)-    traceShowM balance1-    traceShowM balance2-    return (balance1 == Just 2000 && balance2 == Just (-2000))--readAndWriteTransactionsTest :: Test-readAndWriteTransactionsTest connection1 connection2 =-  do-    id1 <- session connection1 (B.statement 0 D.createAccount)-    id2 <- session connection1 (B.statement 0 D.createAccount)-    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)-    balance2 <- session connection1 (B.statement id2 D.getBalance)-    traceShowM balance1-    traceShowM balance2-    return (balance1 == Just 1000 && balance2 == Just (-1000))--transactionAndQueryTest :: Test-transactionAndQueryTest connection1 connection2 =-  do-    id1 <- session connection1 (B.statement 0 D.createAccount)-    id2 <- session connection1 (B.statement 0 D.createAccount)-    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-    balance1 <- session connection1 (B.statement id1 D.getBalance)-    balance2 <- session connection1 (B.statement id2 D.getBalance)-    traceShowM balance1-    traceShowM balance2-    return (balance1 == Just 400 && balance2 == Just (-200))
− conflicts-test/Main/Statements.hs 
@@ -1,46 +0,0 @@-module Main.Statements where--import Contravariant.Extras-import qualified Hasql.Decoders as D-import qualified Hasql.Encoders as E-import Hasql.Statement-import Prelude--createAccountTable :: Statement () ()-createAccountTable =-  Statement sql E.noParams D.noResult False-  where-    sql =-      "create table account (id serial not null, balance numeric not null, primary key (id))"--dropAccountTable :: Statement () ()-dropAccountTable =-  Statement-    "drop table account"-    E.noParams-    D.noResult-    False--createAccount :: Statement Scientific Int64-createAccount =-  Statement-    "insert into account (balance) values ($1) returning id"-    ((E.param . E.nonNullable) E.numeric)-    (D.singleRow ((D.column . D.nonNullable) D.int8))-    True--modifyBalance :: Statement (Int64, Scientific) Bool-modifyBalance =-  Statement-    "update account set balance = balance + $2 where id = $1"-    (contrazip2 ((E.param . E.nonNullable) E.int8) ((E.param . E.nonNullable) E.numeric))-    (fmap (> 0) D.rowsAffected)-    True--getBalance :: Statement Int64 (Maybe Scientific)-getBalance =-  Statement-    "select balance from account where id = $1"-    ((E.param . E.nonNullable) E.int8)-    (D.rowMaybe ((D.column . D.nonNullable) D.numeric))-    True
− conflicts-test/Main/Transactions.hs 
@@ -1,27 +0,0 @@-module Main.Transactions where--import Hasql.Transaction-import qualified Main.Statements as A-import Prelude--createSchema :: Transaction ()-createSchema =-  do-    statement () A.createAccountTable--dropSchema :: Transaction ()-dropSchema =-  do-    statement () A.dropAccountTable--transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool-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)
hasql-transaction.cabal view
@@ -1,30 +1,30 @@-name:          hasql-transaction-version:       1.0.1.4-category:      Hasql, Database, PostgreSQL+cabal-version: 3.0+name: hasql-transaction+version: 1.2.2+category: Hasql, Database, PostgreSQL synopsis:   Composable abstraction over 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 <nikita.y.volkov@mail.ru>-maintainer:    Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:     (c) 2015, Nikita Volkov-license:       MIT-license-file:  LICENSE-build-type:    Simple-cabal-version: >=1.10+homepage: https://github.com/nikita-volkov/hasql-transaction+bug-reports: https://github.com/nikita-volkov/hasql-transaction/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2015, Nikita Volkov+license: MIT+license-file: LICENSE+extra-source-files: CHANGELOG.md+tested-with: ghc ==9.8.2 || ==8.10.1  source-repository head-  type:     git-  location: git://github.com/nikita-volkov/hasql-transaction.git+  type: git+  location: https://github.com/nikita-volkov/hasql-transaction -library-  hs-source-dirs:     library+common base+  default-language: Haskell2010   default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows+    ApplicativeDo     BangPatterns+    BlockArguments     ConstraintKinds     DataKinds     DefaultSignatures@@ -33,32 +33,51 @@     DeriveFunctor     DeriveGeneric     DeriveTraversable+    DerivingVia     EmptyDataDecls     FlexibleContexts     FlexibleInstances     FunctionalDependencies     GADTs     GeneralizedNewtypeDeriving+    ImportQualifiedPost     LambdaCase     LiberalTypeSynonyms-    MagicHash     MultiParamTypeClasses     MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction     OverloadedStrings-    ParallelListComp     PatternGuards     QuasiQuotes     RankNTypes     RecordWildCards+    RoleAnnotations     ScopedTypeVariables     StandaloneDeriving-    TemplateHaskell+    StrictData     TupleSections     TypeFamilies     TypeOperators-    UnboxedTuples -  default-language:   Haskell2010+common executable+  import: base+  ghc-options:+    -O2+    -threaded+    -with-rtsopts=-N+    -rtsopts+    -funbox-strict-fields++common test+  import: base+  ghc-options:+    -threaded+    -with-rtsopts=-N++library+  import: base+  hs-source-dirs: src/library   exposed-modules:     Hasql.Transaction     Hasql.Transaction.Sessions@@ -66,72 +85,37 @@   other-modules:     Hasql.Transaction.Config     Hasql.Transaction.Private.Prelude-    Hasql.Transaction.Private.Sessions     Hasql.Transaction.Private.SQL+    Hasql.Transaction.Private.Sessions     Hasql.Transaction.Private.Statements     Hasql.Transaction.Private.Transaction    build-depends:-      base >=4.12 && <5-    , bytestring >=0.10 && <0.13-    , bytestring-tree-builder >=0.2.7.8 && <0.3-    , contravariant >=1.3 && <2-    , contravariant-extras >=0.3 && <0.4-    , hasql >=1.6 && <1.7-    , mtl >=2.2 && <3-    , transformers >=0.5 && <0.7+    base >=4.12 && <5,+    bytestring >=0.10 && <0.13,+    bytestring-tree-builder >=0.2.7.8 && <0.3,+    contravariant >=1.3 && <2,+    hasql >=1.10 && <1.11,+    mtl >=2.2 && <3,+    text >=1 && <3,+    transformers >=0.5 && <0.7,  test-suite conflicts-test-  type:               exitcode-stdio-1.0-  hs-source-dirs:     conflicts-test-  default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows-    BangPatterns-    ConstraintKinds-    DataKinds-    DefaultSignatures-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    EmptyDataDecls-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    LambdaCase-    LiberalTypeSynonyms-    MagicHash-    MultiParamTypeClasses-    MultiWayIf-    OverloadedStrings-    ParallelListComp-    PatternGuards-    QuasiQuotes-    RankNTypes-    RecordWildCards-    ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeFamilies-    TypeOperators-    UnboxedTuples--  default-language:   Haskell2010-  main-is:            Main.hs+  import: test+  type: exitcode-stdio-1.0+  hs-source-dirs: src/conflicts-test+  main-is: Main.hs   other-modules:     Main.Statements     Main.Transactions -  ghc-options:        -O2 -threaded -with-rtsopts=-N+  ghc-options:+    -O2+    -threaded+    -with-rtsopts=-N+   build-depends:-      async >=2.1 && <3-    , contravariant-extras >=0.3 && <0.4-    , hasql-    , hasql-transaction-    , rerebase >=1.11 && <2+    async >=2.1 && <3,+    hasql >=1.9,+    hasql-transaction,+    rerebase >=1.11 && <2,
− library/Hasql/Transaction.hs 
@@ -1,12 +0,0 @@--- |--- An API for declaration of transactions.-module Hasql.Transaction-  ( -- * Transaction monad-    Transaction,-    condemn,-    sql,-    statement,-  )-where--import Hasql.Transaction.Private.Transaction
− library/Hasql/Transaction/Config.hs 
@@ -1,21 +0,0 @@-module Hasql.Transaction.Config 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--- <http://www.postgresql.org/docs/current/static/transaction-iso.html the Postgres' documentation>.-data IsolationLevel-  = ReadCommitted-  | RepeatableRead-  | Serializable-  deriving (Show, Eq, Ord, Enum, Bounded)
− library/Hasql/Transaction/Private/Prelude.hs 
@@ -1,81 +0,0 @@-module Hasql.Transaction.Private.Prelude-  ( module Exports,-    tryError,-  )-where--import Contravariant.Extras as Exports-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 (fail, forM, forM_, join, mapM, mapM_, msum, sequence, sequence_)-import Control.Monad.Error.Class as Exports (MonadError (..))-import Control.Monad.Fail as Exports-import Control.Monad.Fix as Exports hiding (fix)-import Control.Monad.IO.Class as Exports-import Control.Monad.ST 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)-import Data.Bits as Exports-import Data.Bool as Exports-import Data.ByteString as Exports (ByteString)-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 hiding (unzip)-import Data.Functor.Contravariant as Exports-import Data.Functor.Contravariant.Divisible as Exports-import Data.Functor.Identity as Exports-import Data.IORef as Exports-import Data.Int as Exports-import Data.Ix as Exports-import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)-import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Alt, First (..), Last (..), (<>))-import Data.Ord as Exports-import Data.Proxy as Exports-import Data.Ratio as Exports-import Data.STRef as Exports-import Data.Semigroup 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 (alignment, sizeOf)-import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)-import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)-import GHC.Generics as Exports (Generic, Generic1)-import GHC.IO.Exception as Exports-import Numeric as Exports-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.Printf as Exports (hPrintf, printf)-import Text.Read as Exports (Read (..), readEither, readMaybe)-import Unsafe.Coerce as Exports-import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))--tryError :: (MonadError e m) => m a -> m (Either e a)-tryError m =-  catchError (liftM Right m) (return . Left)
− library/Hasql/Transaction/Private/SQL.hs 
@@ -1,30 +0,0 @@-module Hasql.Transaction.Private.SQL where--import qualified ByteString.TreeBuilder as D-import Hasql.Transaction.Config-import Hasql.Transaction.Private.Prelude--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
− library/Hasql/Transaction/Private/Sessions.hs 
@@ -1,43 +0,0 @@-module Hasql.Transaction.Private.Sessions where--import Hasql.Session-import Hasql.Transaction.Config-import Hasql.Transaction.Private.Prelude-import qualified Hasql.Transaction.Private.Statements as Statements--{--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 -> Session (a, Bool) -> Bool -> Session a-inRetryingTransaction level mode session preparable =-  fix $ \retry -> do-    attemptRes <- tryTransaction level mode session preparable-    case attemptRes of-      Just a -> return a-      Nothing -> retry--tryTransaction :: IsolationLevel -> Mode -> Session (a, Bool) -> Bool -> Session (Maybe a)-tryTransaction level mode body preparable = do-  statement () (Statements.beginTransaction level mode preparable)--  bodyRes <- catchError (fmap Just body) $ \error -> do-    statement () (Statements.abortTransaction preparable)-    handleTransactionError error $ return Nothing--  case bodyRes of-    Just (res, commit) -> catchError (commitOrAbort commit preparable $> Just res) $ \error -> do-      handleTransactionError error $ return Nothing-    Nothing -> return Nothing--commitOrAbort :: Bool -> Bool -> Session ()-commitOrAbort commit preparable =-  if commit-    then statement () (Statements.commitTransaction preparable)-    else statement () (Statements.abortTransaction preparable)--handleTransactionError :: QueryError -> Session a -> Session a-handleTransactionError error onTransactionError = case error of-  QueryError _ _ (ResultError (ServerError "40001" _ _ _ _)) -> onTransactionError-  error -> throwError error
− library/Hasql/Transaction/Private/Statements.hs 
@@ -1,45 +0,0 @@-module Hasql.Transaction.Private.Statements where--import qualified Hasql.Decoders as C-import qualified Hasql.Encoders as B-import qualified Hasql.Statement as A-import Hasql.Transaction.Config-import Hasql.Transaction.Private.Prelude-import qualified Hasql.Transaction.Private.SQL as D---- * Transactions--beginTransaction :: IsolationLevel -> Mode -> Bool -> A.Statement () ()-beginTransaction isolation mode preparable =-  A.Statement (D.beginTransaction isolation mode) B.noParams C.noResult preparable--commitTransaction :: Bool -> A.Statement () ()-commitTransaction preparable =-  A.Statement "COMMIT" B.noParams C.noResult preparable--abortTransaction :: Bool -> A.Statement () ()-abortTransaction preparable =-  A.Statement "ABORT" B.noParams C.noResult preparable---- * 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
− library/Hasql/Transaction/Private/Transaction.hs 
@@ -1,53 +0,0 @@-module Hasql.Transaction.Private.Transaction where--import qualified Hasql.Session as B-import qualified Hasql.Statement as A-import Hasql.Transaction.Config-import Hasql.Transaction.Private.Prelude-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---- |--- Execute the transaction using the provided isolation level and mode.-{-# INLINE run #-}-run :: Transaction a -> IsolationLevel -> Mode -> Bool -> B.Session a-run (Transaction session) isolation mode preparable =-  D.inRetryingTransaction isolation mode (runStateT session True) preparable---- |--- 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
− library/Hasql/Transaction/Sessions.hs 
@@ -1,31 +0,0 @@-module Hasql.Transaction.Sessions-  ( transaction,-    unpreparedTransaction,--    -- * Transaction settings-    C.Mode (..),-    C.IsolationLevel (..),-  )-where--import Data.Bool-import qualified Hasql.Session as B-import qualified Hasql.Transaction.Config as C-import qualified Hasql.Transaction.Private.Transaction as A---- |--- 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 True---- |--- Execute the transaction using the provided isolation level and mode,--- and specifying that the generated BEGIN, COMMIT and ABORT statements should not be prepared.------ Helps with transaction pooling due to its incompatibility with prepared statements.-{-# INLINE unpreparedTransaction #-}-unpreparedTransaction :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a-unpreparedTransaction isolation mode transaction =-  A.run transaction isolation mode False
+ src/conflicts-test/Main.hs view
@@ -0,0 +1,121 @@+module Main where++import Control.Concurrent.Async qualified as F+import Hasql.Connection qualified as A+import Hasql.Connection.Settings qualified as H+import Hasql.Session qualified as B+import Hasql.Transaction qualified as C+import Hasql.Transaction.Sessions qualified as G+import Main.Statements qualified as D+import Main.Transactions qualified as E+import Prelude++main :: IO ()+main =+  bracket acquire release use+  where+    acquire =+      (,) <$> acquire <*> acquire+      where+        acquire =+          join+            $ fmap (either (fail . show) return)+            $ A.acquire connectionSettings+          where+            connectionSettings =+              H.hostAndPort "localhost" 5432+                <> H.user "postgres"+                <> H.password "postgres"+                <> H.dbname "postgres"+    release (connection1, connection2) =+      do+        transaction connection1 E.dropSchema+        A.release connection1+        A.release connection2+    use (connection1, connection2) =+      do+        try (transaction connection1 E.dropSchema) :: IO (Either SomeException ())+        transaction connection1 E.createSchema+        success <- fmap and (traverse runTest tests)+        if success+          then exitSuccess+          else exitFailure+      where+        runTest test =+          test connection1 connection2+        tests =+          [readAndWriteTransactionsTest, transactionsTest, transactionsNoRetryTest, transactionAndQueryTest]++session :: A.Connection -> B.Session a -> IO a+session connection session =+  A.use connection session+    >>= either (fail . show) return++transaction :: A.Connection -> C.Transaction a -> IO a+transaction connection transaction =+  session connection (G.transaction G.RepeatableRead G.Write transaction)++transactionNoRetry :: A.Connection -> C.Transaction a -> IO a+transactionNoRetry connection transaction =+  session connection (G.transactionNoRetry G.RepeatableRead G.Write transaction)++type Test =+  A.Connection -> A.Connection -> IO Bool++transactionsTest :: Test+transactionsTest connection1 connection2 =+  do+    id1 <- session connection1 (B.statement 0 D.createAccount)+    id2 <- session connection1 (B.statement 0 D.createAccount)+    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)+    balance2 <- session connection1 (B.statement id2 D.getBalance)+    traceShowM balance1+    traceShowM balance2+    return (balance1 == Just 2000 && balance2 == Just (-2000))++transactionsNoRetryTest :: Test+transactionsNoRetryTest connection1 connection2 =+  do+    id1 <- session connection1 (B.statement 0 D.createAccount)+    id2 <- session connection1 (B.statement 0 D.createAccount)+    async1 <- F.async (replicateM_ 1000 (transactionNoRetry connection1 (E.transfer id1 id2 1)))+    async2 <- F.async (replicateM_ 1000 (transactionNoRetry connection2 (E.transfer id1 id2 1)))+    result1 <- F.waitCatch async1+    result2 <- F.waitCatch async2+    let serialError = sequenceA [result1, result2]+    traceShowM serialError+    return $ either (("40001" `isInfixOf`) . show) (pure False) serialError++readAndWriteTransactionsTest :: Test+readAndWriteTransactionsTest connection1 connection2 =+  do+    id1 <- session connection1 (B.statement 0 D.createAccount)+    id2 <- session connection1 (B.statement 0 D.createAccount)+    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)+    balance2 <- session connection1 (B.statement id2 D.getBalance)+    traceShowM balance1+    traceShowM balance2+    return (balance1 == Just 1000 && balance2 == Just (-1000))++transactionAndQueryTest :: Test+transactionAndQueryTest connection1 connection2 =+  do+    id1 <- session connection1 (B.statement 0 D.createAccount)+    id2 <- session connection1 (B.statement 0 D.createAccount)+    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+    balance1 <- session connection1 (B.statement id1 D.getBalance)+    balance2 <- session connection1 (B.statement id2 D.getBalance)+    traceShowM balance1+    traceShowM balance2+    return (balance1 == Just 400 && balance2 == Just (-200))
+ src/conflicts-test/Main/Statements.hs view
@@ -0,0 +1,41 @@+module Main.Statements where++import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement+import Prelude++createAccountTable :: Statement () ()+createAccountTable =+  unpreparable sql E.noParams D.noResult+  where+    sql =+      "create table account (id bigserial not null, balance numeric not null, primary key (id))"++dropAccountTable :: Statement () ()+dropAccountTable =+  unpreparable+    "drop table account"+    E.noParams+    D.noResult++createAccount :: Statement Scientific Int64+createAccount =+  preparable+    "insert into account (balance) values ($1) returning id"+    ((E.param . E.nonNullable) E.numeric)+    (D.singleRow ((D.column . D.nonNullable) D.int8))++modifyBalance :: Statement (Int64, Scientific) Bool+modifyBalance =+  preparable+    "update account set balance = balance + $2 where id = $1"+    ((fst >$< (E.param . E.nonNullable) E.int8) <> (snd >$< (E.param . E.nonNullable) E.numeric))+    (fmap (> 0) D.rowsAffected)++getBalance :: Statement Int64 (Maybe Scientific)+getBalance =+  preparable+    "select balance from account where id = $1"+    ((E.param . E.nonNullable) E.int8)+    (D.rowMaybe ((D.column . D.nonNullable) D.numeric))
+ src/conflicts-test/Main/Transactions.hs view
@@ -0,0 +1,27 @@+module Main.Transactions where++import Hasql.Transaction+import Main.Statements qualified as A+import Prelude++createSchema :: Transaction ()+createSchema =+  do+    statement () A.createAccountTable++dropSchema :: Transaction ()+dropSchema =+  do+    statement () A.dropAccountTable++transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool+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)
+ src/library/Hasql/Transaction.hs view
@@ -0,0 +1,12 @@+-- |+-- An API for declaration of transactions.+module Hasql.Transaction+  ( -- * Transaction monad+    Transaction,+    condemn,+    sql,+    statement,+  )+where++import Hasql.Transaction.Private.Transaction
+ src/library/Hasql/Transaction/Config.hs view
@@ -0,0 +1,21 @@+module Hasql.Transaction.Config 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+-- <http://www.postgresql.org/docs/current/static/transaction-iso.html the Postgres' documentation>.+data IsolationLevel+  = ReadCommitted+  | RepeatableRead+  | Serializable+  deriving (Show, Eq, Ord, Enum, Bounded)
+ src/library/Hasql/Transaction/Private/Prelude.hs view
@@ -0,0 +1,80 @@+module Hasql.Transaction.Private.Prelude+  ( module Exports,+    tryError,+  )+where++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 (fail, forM, forM_, join, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Error.Class as Exports (MonadError (..))+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST 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)+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+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 hiding (unzip)+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports+import Data.Functor.Identity as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt, First (..), Last (..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.Semigroup 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 (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic, Generic1)+import GHC.IO.Exception as Exports+import Numeric as Exports+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.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))++tryError :: (MonadError e m) => m a -> m (Either e a)+tryError m =+  catchError (liftM Right m) (return . Left)
+ src/library/Hasql/Transaction/Private/SQL.hs view
@@ -0,0 +1,22 @@+module Hasql.Transaction.Private.SQL where++import ByteString.TreeBuilder qualified as D+import Hasql.Transaction.Config+import Hasql.Transaction.Private.Prelude++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"
+ src/library/Hasql/Transaction/Private/Sessions.hs view
@@ -0,0 +1,55 @@+module Hasql.Transaction.Private.Sessions where++import Hasql.Errors (ServerError (..), SessionError (..), StatementError (..))+import Hasql.Session+import Hasql.Transaction.Config+import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Statements qualified as Statements++{-+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 -> Bool -> Session (a, Bool) -> Session a+inRetryingTransaction level mode retryOnError session =+  fix $ \retry -> do+    attemptRes <- tryTransaction level mode retryOnError session+    case attemptRes of+      Just a -> return a+      Nothing -> retry++tryTransaction :: IsolationLevel -> Mode -> Bool -> Session (a, Bool) -> Session (Maybe a)+tryTransaction level mode retryOnError body = do+  statement () (Statements.beginTransaction level mode)++  bodyRes <- catchError (fmap Just body) $ \error -> do+    statement () Statements.abortTransaction+    handleTransactionError error retryOnError $ return Nothing++  case bodyRes of+    Just (res, commit) -> catchError (commitOrAbort commit $> Just res) $ \error -> do+      handleTransactionError error retryOnError $ return Nothing+    Nothing -> return Nothing++commitOrAbort :: Bool -> Session ()+commitOrAbort commit =+  if commit+    then statement () Statements.commitTransaction+    else statement () Statements.abortTransaction++handleTransactionError :: SessionError -> Bool -> Session a -> Session a+handleTransactionError error retryOnError onTransactionError = case error of+  StatementSessionError _ _ _ _ _ statementError -> onStatementError statementError+  ScriptSessionError _ serverError -> onServerError serverError+  _ -> throwError error+  where+    retryOrThrow = if retryOnError then onTransactionError else throwError error+    onStatementError = \case+      ServerStatementError serverError -> onServerError serverError+      _ -> throwError error+    onServerError (ServerError code _ _ _ _) =+      case code of+        "40001" -> retryOrThrow+        "40P01" -> retryOrThrow+        _ -> throwError error
+ src/library/Hasql/Transaction/Private/Statements.hs view
@@ -0,0 +1,20 @@+module Hasql.Transaction.Private.Statements where++import Data.Text.Encoding qualified as Text+import Hasql.Decoders qualified as C+import Hasql.Encoders qualified as B+import Hasql.Statement qualified as A+import Hasql.Transaction.Config+import Hasql.Transaction.Private.SQL qualified as D++beginTransaction :: IsolationLevel -> Mode -> A.Statement () ()+beginTransaction isolation mode =+  A.preparable (Text.decodeUtf8 (D.beginTransaction isolation mode)) B.noParams C.noResult++commitTransaction :: A.Statement () ()+commitTransaction =+  A.preparable "COMMIT" B.noParams C.noResult++abortTransaction :: A.Statement () ()+abortTransaction =+  A.preparable "ABORT" B.noParams C.noResult
+ src/library/Hasql/Transaction/Private/Transaction.hs view
@@ -0,0 +1,54 @@+module Hasql.Transaction.Private.Transaction where++import Data.Text.Encoding qualified as Text+import Hasql.Session qualified as B+import Hasql.Statement qualified as A+import Hasql.Transaction.Config+import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Sessions qualified 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++-- |+-- Execute the transaction using the provided isolation level and mode.+{-# INLINE run #-}+run :: Transaction a -> IsolationLevel -> Mode -> Bool -> B.Session a+run (Transaction session) isolation mode retryOnError =+  D.inRetryingTransaction isolation mode retryOnError (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.script . Text.decodeUtf8++-- |+-- 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
+ src/library/Hasql/Transaction/Sessions.hs view
@@ -0,0 +1,28 @@+module Hasql.Transaction.Sessions+  ( transaction,+    transactionNoRetry,++    -- * Transaction settings+    C.Mode (..),+    C.IsolationLevel (..),+  )+where++import Hasql.Session qualified as B+import Hasql.Transaction.Config qualified as C+import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Transaction qualified as A++-- |+-- 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 True++-- |+-- Execute the transaction but do not retry it on errors.+{-# INLINE transactionNoRetry #-}+transactionNoRetry :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a+transactionNoRetry isolation mode transaction =+  A.run transaction isolation mode False