├── cabal.project ├── CHANGELOG.md ├── .github └── workflows │ ├── format.yaml │ ├── on-push-to-master-or-pr.yaml │ ├── on-push-to-release.yaml │ └── check.yaml ├── library └── Hasql │ ├── Transaction.hs │ └── Transaction │ ├── Config.hs │ ├── Private │ ├── Statements.hs │ ├── SQL.hs │ ├── Transaction.hs │ ├── Sessions.hs │ └── Prelude.hs │ └── Sessions.hs ├── conflicts-test ├── Main │ ├── Transactions.hs │ └── Statements.hs └── Main.hs ├── LICENSE └── hasql-transaction.cabal /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | allow-newer: 3 | , *:base 4 | , *:template-haskell 5 | , *:ghc-prim 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.2 2 | 3 | - Removed the `unpreparedTransaction` session because the same effects can now be achieved via the connection settings in Hasql 4 | 5 | # 1.1 6 | 7 | - Add automatic retry on deadlock errors (code 40P01) 8 | -------------------------------------------------------------------------------- /.github/workflows/format.yaml: -------------------------------------------------------------------------------- 1 | name: Format 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | format: 8 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 9 | secrets: inherit 10 | -------------------------------------------------------------------------------- /library/Hasql/Transaction.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- An API for declaration of transactions. 3 | module Hasql.Transaction 4 | ( -- * Transaction monad 5 | Transaction, 6 | condemn, 7 | sql, 8 | statement, 9 | ) 10 | where 11 | 12 | import Hasql.Transaction.Private.Transaction 13 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-master-or-pr.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | 11 | format: 12 | uses: ./.github/workflows/format.yaml 13 | secrets: inherit 14 | 15 | check: 16 | uses: ./.github/workflows/check.yaml 17 | secrets: inherit 18 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Config.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Config where 2 | 3 | import Hasql.Transaction.Private.Prelude 4 | 5 | data Mode 6 | = -- | 7 | -- Read-only. No writes possible. 8 | Read 9 | | -- | 10 | -- Write and commit. 11 | Write 12 | deriving (Show, Eq, Ord, Enum, Bounded) 13 | 14 | -- | 15 | -- For reference see 16 | -- . 17 | data IsolationLevel 18 | = ReadCommitted 19 | | RepeatableRead 20 | | Serializable 21 | deriving (Show, Eq, Ord, Enum, Bounded) 22 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-release.yaml: -------------------------------------------------------------------------------- 1 | name: Release the lib to Hackage 2 | 3 | on: 4 | push: 5 | branches: 6 | - supermajor 7 | - major 8 | - minor 9 | - patch 10 | 11 | concurrency: 12 | group: release 13 | cancel-in-progress: false 14 | 15 | jobs: 16 | 17 | format: 18 | uses: ./.github/workflows/format.yaml 19 | secrets: inherit 20 | 21 | check: 22 | uses: ./.github/workflows/check.yaml 23 | secrets: inherit 24 | 25 | release: 26 | needs: 27 | - format 28 | - check 29 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/release.yaml@v3 30 | secrets: inherit 31 | with: 32 | prefix-tag-with-v: false 33 | docs: true 34 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Private/Statements.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Private.Statements where 2 | 3 | import Hasql.Decoders qualified as C 4 | import Hasql.Encoders qualified as B 5 | import Hasql.Statement qualified as A 6 | import Hasql.Transaction.Config 7 | import Hasql.Transaction.Private.Prelude 8 | import Hasql.Transaction.Private.SQL qualified as D 9 | 10 | beginTransaction :: IsolationLevel -> Mode -> A.Statement () () 11 | beginTransaction isolation mode = 12 | A.Statement (D.beginTransaction isolation mode) B.noParams C.noResult True 13 | 14 | commitTransaction :: A.Statement () () 15 | commitTransaction = 16 | A.Statement "COMMIT" B.noParams C.noResult True 17 | 18 | abortTransaction :: A.Statement () () 19 | abortTransaction = 20 | A.Statement "ABORT" B.noParams C.noResult True 21 | -------------------------------------------------------------------------------- /conflicts-test/Main/Transactions.hs: -------------------------------------------------------------------------------- 1 | module Main.Transactions where 2 | 3 | import Hasql.Transaction 4 | import Main.Statements qualified as A 5 | import Prelude 6 | 7 | createSchema :: Transaction () 8 | createSchema = 9 | do 10 | statement () A.createAccountTable 11 | 12 | dropSchema :: Transaction () 13 | dropSchema = 14 | do 15 | statement () A.dropAccountTable 16 | 17 | transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool 18 | transfer id1 id2 amount = 19 | do 20 | success <- statement (id1, amount) A.modifyBalance 21 | if success 22 | then statement (id2, negate amount) A.modifyBalance 23 | else return False 24 | 25 | transferTimes :: Int -> Int64 -> Int64 -> Scientific -> Transaction () 26 | transferTimes times id1 id2 amount = 27 | replicateM_ times (transfer id1 id2 amount) 28 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Private/SQL.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Private.SQL where 2 | 3 | import ByteString.TreeBuilder qualified as D 4 | import Hasql.Transaction.Config 5 | import Hasql.Transaction.Private.Prelude 6 | 7 | beginTransaction :: IsolationLevel -> Mode -> ByteString 8 | beginTransaction isolation mode = 9 | D.toByteString builder 10 | where 11 | builder = 12 | "BEGIN " <> isolationBuilder <> " " <> modeBuilder 13 | where 14 | isolationBuilder = 15 | case isolation of 16 | ReadCommitted -> "ISOLATION LEVEL READ COMMITTED" 17 | RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ" 18 | Serializable -> "ISOLATION LEVEL SERIALIZABLE" 19 | modeBuilder = 20 | case mode of 21 | Write -> "READ WRITE" 22 | Read -> "READ ONLY" 23 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Sessions.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Sessions 2 | ( transaction, 3 | transactionNoRetry, 4 | 5 | -- * Transaction settings 6 | C.Mode (..), 7 | C.IsolationLevel (..), 8 | ) 9 | where 10 | 11 | import Hasql.Session qualified as B 12 | import Hasql.Transaction.Config qualified as C 13 | import Hasql.Transaction.Private.Prelude 14 | import Hasql.Transaction.Private.Transaction qualified as A 15 | 16 | -- | 17 | -- Execute the transaction using the provided isolation level and mode. 18 | {-# INLINE transaction #-} 19 | transaction :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a 20 | transaction isolation mode transaction = 21 | A.run transaction isolation mode True 22 | 23 | -- | 24 | -- Execute the transaction but do not retry it on errors. 25 | {-# INLINE transactionNoRetry #-} 26 | transactionNoRetry :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a 27 | transactionNoRetry isolation mode transaction = 28 | A.run transaction isolation mode False 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Nikita Volkov 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /.github/workflows/check.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | 8 | check: 9 | 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | include: 14 | - ghc: 8.10.1 15 | ghc-options: "" 16 | ignore-haddock: true 17 | ignore-cabal-check: true 18 | - ghc: latest 19 | ignore-cabal-check: true 20 | 21 | runs-on: ubuntu-latest 22 | 23 | services: 24 | postgres: 25 | image: postgres 26 | env: 27 | POSTGRES_USER: postgres 28 | POSTGRES_DB: postgres 29 | POSTGRES_PASSWORD: postgres 30 | ports: 31 | - 5432:5432 32 | options: >- 33 | --health-cmd pg_isready 34 | --health-interval 10s 35 | --health-timeout 5s 36 | --health-retries 5 37 | 38 | steps: 39 | 40 | - uses: nikita-volkov/build-and-test-cabal-package.github-action@v1 41 | with: 42 | ghc: ${{matrix.ghc}} 43 | ghc-options: ${{matrix.ghc-options}} 44 | ignore-haddock: ${{matrix.ignore-haddock}} 45 | ignore-cabal-check: ${{matrix.ignore-cabal-check}} 46 | -------------------------------------------------------------------------------- /conflicts-test/Main/Statements.hs: -------------------------------------------------------------------------------- 1 | module Main.Statements where 2 | 3 | import Hasql.Decoders qualified as D 4 | import Hasql.Encoders qualified as E 5 | import Hasql.Statement 6 | import Prelude 7 | 8 | createAccountTable :: Statement () () 9 | createAccountTable = 10 | Statement sql E.noParams D.noResult False 11 | where 12 | sql = 13 | "create table account (id serial not null, balance numeric not null, primary key (id))" 14 | 15 | dropAccountTable :: Statement () () 16 | dropAccountTable = 17 | Statement 18 | "drop table account" 19 | E.noParams 20 | D.noResult 21 | False 22 | 23 | createAccount :: Statement Scientific Int64 24 | createAccount = 25 | Statement 26 | "insert into account (balance) values ($1) returning id" 27 | ((E.param . E.nonNullable) E.numeric) 28 | (D.singleRow ((D.column . D.nonNullable) D.int8)) 29 | True 30 | 31 | modifyBalance :: Statement (Int64, Scientific) Bool 32 | modifyBalance = 33 | Statement 34 | "update account set balance = balance + $2 where id = $1" 35 | ((fst >$< (E.param . E.nonNullable) E.int8) <> (snd >$< (E.param . E.nonNullable) E.numeric)) 36 | (fmap (> 0) D.rowsAffected) 37 | True 38 | 39 | getBalance :: Statement Int64 (Maybe Scientific) 40 | getBalance = 41 | Statement 42 | "select balance from account where id = $1" 43 | ((E.param . E.nonNullable) E.int8) 44 | (D.rowMaybe ((D.column . D.nonNullable) D.numeric)) 45 | True 46 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Private/Transaction.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Private.Transaction where 2 | 3 | import Hasql.Session qualified as B 4 | import Hasql.Statement qualified as A 5 | import Hasql.Transaction.Config 6 | import Hasql.Transaction.Private.Prelude 7 | import Hasql.Transaction.Private.Sessions qualified as D 8 | 9 | -- | 10 | -- A composable abstraction over the retryable transactions. 11 | -- 12 | -- Executes multiple queries under the specified mode and isolation level, 13 | -- while automatically retrying the transaction in case of conflicts. 14 | -- Thus this abstraction closely reproduces the behaviour of 'STM'. 15 | newtype Transaction a 16 | = Transaction (StateT Bool B.Session a) 17 | deriving (Functor, Applicative, Monad) 18 | 19 | instance (Semigroup a) => Semigroup (Transaction a) where 20 | (<>) = liftA2 (<>) 21 | 22 | instance (Monoid a) => Monoid (Transaction a) where 23 | mempty = pure mempty 24 | 25 | -- | 26 | -- Execute the transaction using the provided isolation level and mode. 27 | {-# INLINE run #-} 28 | run :: Transaction a -> IsolationLevel -> Mode -> Bool -> B.Session a 29 | run (Transaction session) isolation mode retryOnError = 30 | D.inRetryingTransaction isolation mode retryOnError (runStateT session True) 31 | 32 | -- | 33 | -- Possibly a multi-statement query, 34 | -- which however cannot be parameterized or prepared, 35 | -- nor can any results of it be collected. 36 | {-# INLINE sql #-} 37 | sql :: ByteString -> Transaction () 38 | sql = 39 | Transaction . lift . B.sql 40 | 41 | -- | 42 | -- Parameters and a specification of the parametric query to apply them to. 43 | {-# INLINE statement #-} 44 | statement :: a -> A.Statement a b -> Transaction b 45 | statement params statement = 46 | Transaction . lift $ B.statement params statement 47 | 48 | -- | 49 | -- Cause transaction to eventually roll back. 50 | {-# INLINE condemn #-} 51 | condemn :: Transaction () 52 | condemn = 53 | Transaction $ put False 54 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Private/Sessions.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Private.Sessions where 2 | 3 | import Hasql.Session 4 | import Hasql.Transaction.Config 5 | import Hasql.Transaction.Private.Prelude 6 | import Hasql.Transaction.Private.Statements qualified as Statements 7 | 8 | {- 9 | We may want to 10 | do one transaction retry in case of the 23505 error, and fail if an identical 11 | error is seen. 12 | -} 13 | inRetryingTransaction :: IsolationLevel -> Mode -> Bool -> Session (a, Bool) -> Session a 14 | inRetryingTransaction level mode retryOnError session = 15 | fix $ \retry -> do 16 | attemptRes <- tryTransaction level mode retryOnError session 17 | case attemptRes of 18 | Just a -> return a 19 | Nothing -> retry 20 | 21 | tryTransaction :: IsolationLevel -> Mode -> Bool -> Session (a, Bool) -> Session (Maybe a) 22 | tryTransaction level mode retryOnError body = do 23 | statement () (Statements.beginTransaction level mode) 24 | 25 | bodyRes <- catchError (fmap Just body) $ \error -> do 26 | statement () Statements.abortTransaction 27 | handleTransactionError error retryOnError $ return Nothing 28 | 29 | case bodyRes of 30 | Just (res, commit) -> catchError (commitOrAbort commit $> Just res) $ \error -> do 31 | handleTransactionError error retryOnError $ return Nothing 32 | Nothing -> return Nothing 33 | 34 | commitOrAbort :: Bool -> Session () 35 | commitOrAbort commit = 36 | if commit 37 | then statement () Statements.commitTransaction 38 | else statement () Statements.abortTransaction 39 | 40 | handleTransactionError :: SessionError -> Bool -> Session a -> Session a 41 | handleTransactionError error retryOnError onTransactionError = case error of 42 | QueryError _ _ clientError -> onCommandError clientError 43 | PipelineError clientError -> onCommandError clientError 44 | where 45 | retryOrThrow = if retryOnError then onTransactionError else throwError error 46 | onCommandError = \case 47 | ResultError (ServerError code _ _ _ _) -> 48 | case code of 49 | "40001" -> retryOrThrow 50 | "40P01" -> retryOrThrow 51 | _ -> throwError error 52 | _ -> throwError error 53 | -------------------------------------------------------------------------------- /hasql-transaction.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: hasql-transaction 3 | version: 1.2.1 4 | category: Hasql, Database, PostgreSQL 5 | synopsis: 6 | Composable abstraction over retryable transactions for Hasql 7 | 8 | homepage: https://github.com/nikita-volkov/hasql-transaction 9 | bug-reports: https://github.com/nikita-volkov/hasql-transaction/issues 10 | author: Nikita Volkov 11 | maintainer: Nikita Volkov 12 | copyright: (c) 2015, Nikita Volkov 13 | license: MIT 14 | license-file: LICENSE 15 | extra-source-files: CHANGELOG.md 16 | tested-with: ghc ==9.8.2 || ==8.10.1 17 | 18 | source-repository head 19 | type: git 20 | location: git://github.com/nikita-volkov/hasql-transaction.git 21 | 22 | common base 23 | default-language: Haskell2010 24 | default-extensions: 25 | ApplicativeDo 26 | BangPatterns 27 | BlockArguments 28 | ConstraintKinds 29 | DataKinds 30 | DefaultSignatures 31 | DeriveDataTypeable 32 | DeriveFoldable 33 | DeriveFunctor 34 | DeriveGeneric 35 | DeriveTraversable 36 | DerivingVia 37 | EmptyDataDecls 38 | FlexibleContexts 39 | FlexibleInstances 40 | FunctionalDependencies 41 | GADTs 42 | GeneralizedNewtypeDeriving 43 | ImportQualifiedPost 44 | LambdaCase 45 | LiberalTypeSynonyms 46 | MultiParamTypeClasses 47 | MultiWayIf 48 | NoImplicitPrelude 49 | NoMonomorphismRestriction 50 | OverloadedStrings 51 | PatternGuards 52 | QuasiQuotes 53 | RankNTypes 54 | RecordWildCards 55 | RoleAnnotations 56 | ScopedTypeVariables 57 | StandaloneDeriving 58 | StrictData 59 | TupleSections 60 | TypeFamilies 61 | TypeOperators 62 | 63 | common executable 64 | import: base 65 | ghc-options: 66 | -O2 67 | -threaded 68 | -with-rtsopts=-N 69 | -rtsopts 70 | -funbox-strict-fields 71 | 72 | common test 73 | import: base 74 | ghc-options: 75 | -threaded 76 | -with-rtsopts=-N 77 | 78 | library 79 | import: base 80 | hs-source-dirs: library 81 | exposed-modules: 82 | Hasql.Transaction 83 | Hasql.Transaction.Sessions 84 | 85 | other-modules: 86 | Hasql.Transaction.Config 87 | Hasql.Transaction.Private.Prelude 88 | Hasql.Transaction.Private.SQL 89 | Hasql.Transaction.Private.Sessions 90 | Hasql.Transaction.Private.Statements 91 | Hasql.Transaction.Private.Transaction 92 | 93 | build-depends: 94 | base >=4.12 && <5, 95 | bytestring >=0.10 && <0.13, 96 | bytestring-tree-builder >=0.2.7.8 && <0.3, 97 | contravariant >=1.3 && <2, 98 | hasql >=1.9 && <1.10, 99 | mtl >=2.2 && <3, 100 | transformers >=0.5 && <0.7, 101 | 102 | test-suite conflicts-test 103 | import: test 104 | type: exitcode-stdio-1.0 105 | hs-source-dirs: conflicts-test 106 | main-is: Main.hs 107 | other-modules: 108 | Main.Statements 109 | Main.Transactions 110 | 111 | ghc-options: 112 | -O2 113 | -threaded 114 | -with-rtsopts=-N 115 | 116 | build-depends: 117 | async >=2.1 && <3, 118 | hasql >=1.9, 119 | hasql-transaction, 120 | rerebase >=1.11 && <2, 121 | -------------------------------------------------------------------------------- /library/Hasql/Transaction/Private/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Transaction.Private.Prelude 2 | ( module Exports, 3 | tryError, 4 | ) 5 | where 6 | 7 | import Control.Applicative as Exports 8 | import Control.Arrow as Exports 9 | import Control.Category as Exports 10 | import Control.Concurrent as Exports 11 | import Control.Exception as Exports 12 | import Control.Monad as Exports hiding (fail, forM, forM_, join, mapM, mapM_, msum, sequence, sequence_) 13 | import Control.Monad.Error.Class as Exports (MonadError (..)) 14 | import Control.Monad.Fail as Exports 15 | import Control.Monad.Fix as Exports hiding (fix) 16 | import Control.Monad.IO.Class as Exports 17 | import Control.Monad.ST as Exports 18 | import Control.Monad.Trans.Class as Exports 19 | import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) 20 | import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) 21 | import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) 22 | import Data.Bits as Exports 23 | import Data.Bool as Exports 24 | import Data.ByteString as Exports (ByteString) 25 | import Data.Char as Exports 26 | import Data.Coerce as Exports 27 | import Data.Complex as Exports 28 | import Data.Data as Exports 29 | import Data.Dynamic as Exports 30 | import Data.Either as Exports 31 | import Data.Fixed as Exports 32 | import Data.Foldable as Exports hiding (toList) 33 | import Data.Function as Exports hiding (id, (.)) 34 | import Data.Functor as Exports hiding (unzip) 35 | import Data.Functor.Contravariant as Exports 36 | import Data.Functor.Contravariant.Divisible as Exports 37 | import Data.Functor.Identity as Exports 38 | import Data.IORef as Exports 39 | import Data.Int as Exports 40 | import Data.Ix as Exports 41 | 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) 42 | import Data.Maybe as Exports 43 | import Data.Monoid as Exports hiding (Alt, First (..), Last (..), (<>)) 44 | import Data.Ord as Exports 45 | import Data.Proxy as Exports 46 | import Data.Ratio as Exports 47 | import Data.STRef as Exports 48 | import Data.Semigroup as Exports 49 | import Data.String as Exports 50 | import Data.Traversable as Exports 51 | import Data.Tuple as Exports 52 | import Data.Unique as Exports 53 | import Data.Version as Exports 54 | import Data.Word as Exports 55 | import Debug.Trace as Exports 56 | import Foreign.ForeignPtr as Exports 57 | import Foreign.Ptr as Exports 58 | import Foreign.StablePtr as Exports 59 | import Foreign.Storable as Exports hiding (alignment, sizeOf) 60 | import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) 61 | import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) 62 | import GHC.Generics as Exports (Generic, Generic1) 63 | import GHC.IO.Exception as Exports 64 | import Numeric as Exports 65 | import System.Environment as Exports 66 | import System.Exit as Exports 67 | import System.IO as Exports 68 | import System.IO.Error as Exports 69 | import System.IO.Unsafe as Exports 70 | import System.Mem as Exports 71 | import System.Mem.StableName as Exports 72 | import System.Timeout as Exports 73 | import Text.Printf as Exports (hPrintf, printf) 74 | import Text.Read as Exports (Read (..), readEither, readMaybe) 75 | import Unsafe.Coerce as Exports 76 | 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, (.)) 77 | 78 | tryError :: (MonadError e m) => m a -> m (Either e a) 79 | tryError m = 80 | catchError (liftM Right m) (return . Left) 81 | -------------------------------------------------------------------------------- /conflicts-test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.Async qualified as F 4 | import Hasql.Connection qualified as A 5 | import Hasql.Connection.Setting qualified as H 6 | import Hasql.Connection.Setting.Connection qualified as I 7 | import Hasql.Connection.Setting.Connection.Param qualified as J 8 | import Hasql.Session qualified as B 9 | import Hasql.Transaction qualified as C 10 | import Hasql.Transaction.Sessions qualified as G 11 | import Main.Statements qualified as D 12 | import Main.Transactions qualified as E 13 | import Prelude 14 | 15 | main :: IO () 16 | main = 17 | bracket acquire release use 18 | where 19 | acquire = 20 | (,) <$> acquire <*> acquire 21 | where 22 | acquire = 23 | join 24 | $ fmap (either (fail . show) return) 25 | $ A.acquire connectionSettings 26 | where 27 | connectionSettings = 28 | [ H.connection 29 | ( I.params 30 | [ J.host "localhost", 31 | J.port 5432, 32 | J.user "postgres", 33 | J.password "postgres", 34 | J.dbname "postgres" 35 | ] 36 | ) 37 | ] 38 | release (connection1, connection2) = 39 | do 40 | transaction connection1 E.dropSchema 41 | A.release connection1 42 | A.release connection2 43 | use (connection1, connection2) = 44 | do 45 | try (transaction connection1 E.dropSchema) :: IO (Either SomeException ()) 46 | transaction connection1 E.createSchema 47 | success <- fmap and (traverse runTest tests) 48 | if success 49 | then exitSuccess 50 | else exitFailure 51 | where 52 | runTest test = 53 | test connection1 connection2 54 | tests = 55 | [readAndWriteTransactionsTest, transactionsTest, transactionsNoRetryTest, transactionAndQueryTest] 56 | 57 | session :: A.Connection -> B.Session a -> IO a 58 | session connection session = 59 | B.run session connection 60 | >>= either (fail . show) return 61 | 62 | transaction :: A.Connection -> C.Transaction a -> IO a 63 | transaction connection transaction = 64 | session connection (G.transaction G.RepeatableRead G.Write transaction) 65 | 66 | transactionNoRetry :: A.Connection -> C.Transaction a -> IO a 67 | transactionNoRetry connection transaction = 68 | session connection (G.transactionNoRetry G.RepeatableRead G.Write transaction) 69 | 70 | type Test = 71 | A.Connection -> A.Connection -> IO Bool 72 | 73 | transactionsTest :: Test 74 | transactionsTest connection1 connection2 = 75 | do 76 | id1 <- session connection1 (B.statement 0 D.createAccount) 77 | id2 <- session connection1 (B.statement 0 D.createAccount) 78 | async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) 79 | async2 <- F.async (replicateM_ 1000 (transaction connection2 (E.transfer id1 id2 1))) 80 | F.wait async1 81 | F.wait async2 82 | balance1 <- session connection1 (B.statement id1 D.getBalance) 83 | balance2 <- session connection1 (B.statement id2 D.getBalance) 84 | traceShowM balance1 85 | traceShowM balance2 86 | return (balance1 == Just 2000 && balance2 == Just (-2000)) 87 | 88 | transactionsNoRetryTest :: Test 89 | transactionsNoRetryTest connection1 connection2 = 90 | do 91 | id1 <- session connection1 (B.statement 0 D.createAccount) 92 | id2 <- session connection1 (B.statement 0 D.createAccount) 93 | async1 <- F.async (replicateM_ 1000 (transactionNoRetry connection1 (E.transfer id1 id2 1))) 94 | async2 <- F.async (replicateM_ 1000 (transactionNoRetry connection2 (E.transfer id1 id2 1))) 95 | result1 <- F.waitCatch async1 96 | result2 <- F.waitCatch async2 97 | let serialError = sequenceA [result1, result2] 98 | traceShowM serialError 99 | return $ either (("40001" `isInfixOf`) . show) (pure False) serialError 100 | 101 | readAndWriteTransactionsTest :: Test 102 | readAndWriteTransactionsTest connection1 connection2 = 103 | do 104 | id1 <- session connection1 (B.statement 0 D.createAccount) 105 | id2 <- session connection1 (B.statement 0 D.createAccount) 106 | async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) 107 | async2 <- F.async (replicateM_ 1000 (transaction connection2 (C.statement id1 D.getBalance))) 108 | F.wait async1 109 | F.wait async2 110 | balance1 <- session connection1 (B.statement id1 D.getBalance) 111 | balance2 <- session connection1 (B.statement id2 D.getBalance) 112 | traceShowM balance1 113 | traceShowM balance2 114 | return (balance1 == Just 1000 && balance2 == Just (-1000)) 115 | 116 | transactionAndQueryTest :: Test 117 | transactionAndQueryTest connection1 connection2 = 118 | do 119 | id1 <- session connection1 (B.statement 0 D.createAccount) 120 | id2 <- session connection1 (B.statement 0 D.createAccount) 121 | async1 <- F.async (transaction connection1 (E.transferTimes 200 id1 id2 1)) 122 | async2 <- F.async (session connection2 (replicateM_ 200 (B.statement (id1, 1) D.modifyBalance))) 123 | F.wait async1 124 | F.wait async2 125 | balance1 <- session connection1 (B.statement id1 D.getBalance) 126 | balance2 <- session connection1 (B.statement id2 D.getBalance) 127 | traceShowM balance1 128 | traceShowM balance2 129 | return (balance1 == Just 400 && balance2 == Just (-200)) 130 | --------------------------------------------------------------------------------