diff --git a/conflicts-test/Main.hs b/conflicts-test/Main.hs new file mode 100644 --- /dev/null +++ b/conflicts-test/Main.hs @@ -0,0 +1,99 @@ +module Main where + +import Prelude +import qualified Hasql.Connection as A +import qualified Hasql.Session as B +import qualified Hasql.Transaction as C +import qualified Main.Statements as D +import qualified Main.Transactions as E +import qualified Control.Concurrent.Async as F + + +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" + release (connection1, connection2) = + do + transact 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 + success <- fmap and (traverse runTest tests) + if success + then exitSuccess + else exitFailure + where + runTest test = + test connection1 connection2 + tests = + [readAndWriteTransactionsTest, transactionsTest, transactionAndQueryTest] + + +session connection session = + B.run session connection >>= + either (fail . show) return + +transact connection transaction = + session connection (C.transact 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 (transact connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transact 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 (transact connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transact connection2 (E.getBalance id1))) + 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 (transact 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)) diff --git a/conflicts-test/Main/Statements.hs b/conflicts-test/Main/Statements.hs new file mode 100644 --- /dev/null +++ b/conflicts-test/Main/Statements.hs @@ -0,0 +1,47 @@ +module Main.Statements where + +import Prelude +import Hasql.Statement +import qualified Hasql.Encoders as E +import qualified Hasql.Decoders as D + + +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 + diff --git a/conflicts-test/Main/Transactions.hs b/conflicts-test/Main/Transactions.hs new file mode 100644 --- /dev/null +++ b/conflicts-test/Main/Transactions.hs @@ -0,0 +1,25 @@ +module Main.Transactions where + +import Prelude +import Hasql.Transaction +import qualified Main.Statements as A + + +createSchema :: Transaction () +createSchema = statement Write Serializable A.createAccountTable () + +dropSchema :: Transaction () +dropSchema = statement Write Serializable 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) + +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 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.8 +version: 0.9 category: Hasql, Database, PostgreSQL -synopsis: A composable abstraction over the retryable transactions for Hasql +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 @@ -23,13 +23,11 @@ exposed-modules: Hasql.Transaction other-modules: + Hasql.Transaction.Builders Hasql.Transaction.Prelude - Hasql.Transaction.Requisites.Model - Hasql.Transaction.Requisites.Builders - Hasql.Transaction.Requisites.Statements - Hasql.Transaction.Requisites.Sessions - Hasql.Transaction.Session - Hasql.Transaction.Transaction + Hasql.Transaction.Sessions + Hasql.Transaction.Statements + Hasql.Transaction.Types build-depends: base >=4.9 && <5, bytestring >=0.10 && <0.11, @@ -40,4 +38,24 @@ mtl >=2 && <3, profunctors >=5 && <6, transformers >=0.3 && <0.6, + selective >=0.3 && <0.4, semigroupoids >=5.3.2 && <6 + +test-suite conflicts-test + type: exitcode-stdio-1.0 + hs-source-dirs: conflicts-test + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 + main-is: Main.hs + other-modules: + Main.Statements + Main.Transactions + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + build-depends: + async >=2.1 && <3, + hasql-transaction, + hasql, + rerebase >=1.4 && <2 diff --git a/library/Hasql/Transaction.hs b/library/Hasql/Transaction.hs --- a/library/Hasql/Transaction.hs +++ b/library/Hasql/Transaction.hs @@ -1,17 +1,16 @@ {-| -Arrow DSL for composition of transactions with automated conflict resolution. +DSL for composition of transactions with automated conflict resolution. -} module Hasql.Transaction ( - {-* Session -} - Session.transact, + {-* Sessions -} + transact, {-* Transaction -} Transaction, statement, sql, session, condemn, - retry, {-* Settings -} Mode(..), Level(..), @@ -23,25 +22,120 @@ * `Reexports.Statement` -} module Reexports, - {-* FAQ -} - {-| - == Why does transaction have to be an arrow, why is monad or applicative not enough? - - Arrow allows us to determine the read mode and isolation level, - while composing transactions in such a way that one can depend on the result of the other. - - A monadic interface wouldn't allow us to do the first, namely: - to compose the modes and levels. - - An applicative interface wouldn't allow the second: - to make a transaction depend on the result of the other. - For details see the docs on the `Transaction` type. - -} ) where -import Hasql.Transaction.Requisites.Model -import Hasql.Transaction.Transaction +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.Transaction.Session as Session +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 consituent 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 Alternative Transaction where + empty = Transaction minBound minBound [] + (<|>) (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] diff --git a/library/Hasql/Transaction/Builders.hs b/library/Hasql/Transaction/Builders.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Builders.hs @@ -0,0 +1,22 @@ +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 --- a/library/Hasql/Transaction/Prelude.hs +++ b/library/Hasql/Transaction/Prelude.hs @@ -53,7 +53,7 @@ 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.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 @@ -72,6 +72,10 @@ 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 ------------------------- diff --git a/library/Hasql/Transaction/Requisites/Builders.hs b/library/Hasql/Transaction/Requisites/Builders.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Requisites/Builders.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Hasql.Transaction.Requisites.Builders -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Requisites.Model -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/Requisites/Model.hs b/library/Hasql/Transaction/Requisites/Model.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Requisites/Model.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Hasql.Transaction.Requisites.Model -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) diff --git a/library/Hasql/Transaction/Requisites/Sessions.hs b/library/Hasql/Transaction/Requisites/Sessions.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Requisites/Sessions.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| - -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.Requisites.Sessions -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Requisites.Model -import Hasql.Session -import qualified Hasql.Transaction.Requisites.Statements as Statements - - -inRetryingTransaction :: Mode -> Level -> Session (a, Condemnation) -> Session a -inRetryingTransaction mode isolation session = - fix $ \ recur -> catchError normal (onError recur) - where - normal = - do - statement () (Statements.beginTransaction mode isolation) - (result, condemnation) <- session - case condemnation of - Uncondemned -> statement () Statements.commitTransaction - Condemned -> statement () Statements.abortTransaction - return result - onError continue error = - do - statement () Statements.abortTransaction - case error of - QueryError _ _ (ResultError (ServerError "40001" _ _ _)) -> continue - _ -> throwError error - -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 session = do - statement () (Statements.beginTransaction mode level) - catchError - (do - (result, condemnation) <- session - case condemnation of - Uncondemned -> statement () Statements.commitTransaction - Condemned -> statement () Statements.abortTransaction - return (Just result)) - (\ error -> do - statement () Statements.abortTransaction - case error of - QueryError _ _ (ResultError (ServerError "40001" _ _ _)) -> return Nothing - error -> throwError error) diff --git a/library/Hasql/Transaction/Requisites/Statements.hs b/library/Hasql/Transaction/Requisites/Statements.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Requisites/Statements.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Hasql.Transaction.Requisites.Statements -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Requisites.Model -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.Requisites.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/Session.hs b/library/Hasql/Transaction/Session.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Session.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-| -Extensions to Session. -Can be used imported in the same namespace as @Hasql.Session@ without conflicts. --} -module Hasql.Transaction.Session -where - -import Hasql.Transaction.Prelude -import Hasql.Transaction.Requisites.Model -import Hasql.Transaction.Requisites.Sessions -import Hasql.Session -import qualified Hasql.Transaction.Transaction as Transaction -import qualified Hasql.Transaction.Transaction as Reexports (Transaction) - - -{-| -Execute an alternating transaction arrow providing an input for it. --} -transact :: Transaction.Transaction i o -> i -> Session o -transact (Transaction.Transaction mode level list) i = - inAlternatingTransaction mode level (fmap (\ fn -> runStateT (fn i) Uncondemned) list) diff --git a/library/Hasql/Transaction/Sessions.hs b/library/Hasql/Transaction/Sessions.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Sessions.hs @@ -0,0 +1,60 @@ +{-| + +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 +where + +import Hasql.Transaction.Prelude +import Hasql.Transaction.Types +import Hasql.Session +import qualified Hasql.Transaction.Statements as Statements + + +inRetryingTransaction :: Mode -> Level -> Session (a, Condemnation) -> Session a +inRetryingTransaction mode isolation session = + fix $ \ recur -> catchError normal (onError recur) + where + normal = + do + statement () (Statements.beginTransaction mode isolation) + (result, condemnation) <- session + case condemnation of + Uncondemned -> statement () Statements.commitTransaction + Condemned -> statement () Statements.abortTransaction + return result + onError continue error = + do + statement () Statements.abortTransaction + case error of + QueryError _ _ (ResultError (ServerError "40001" _ _ _)) -> continue + _ -> throwError error + +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 session = do + statement () (Statements.beginTransaction mode level) + catchError + (do + (result, condemnation) <- session + case condemnation of + Uncondemned -> statement () Statements.commitTransaction + Condemned -> statement () Statements.abortTransaction + return (Just result)) + (\ error -> do + statement () Statements.abortTransaction + case error of + QueryError _ _ (ResultError (ServerError "40001" _ _ _)) -> return Nothing + error -> throwError error) diff --git a/library/Hasql/Transaction/Statements.hs b/library/Hasql/Transaction/Statements.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Statements.hs @@ -0,0 +1,23 @@ +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/Transaction.hs b/library/Hasql/Transaction/Transaction.hs deleted file mode 100644 --- a/library/Hasql/Transaction/Transaction.hs +++ /dev/null @@ -1,155 +0,0 @@ -module Hasql.Transaction.Transaction where - -import Hasql.Transaction.Prelude hiding (map, retry) -import Hasql.Transaction.Requisites.Model -import Hasql.Session (Session) -import Hasql.Statement (Statement) -import qualified Hasql.Session as Session - - -{-| -Composable transaction providing for automated conflict resolution -with input @i@ and output @o@. Supports alternative branching. - -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. --} -data Transaction i o = - Transaction Mode Level [i -> StateT Condemnation Session o] - -deriving instance Functor (Transaction i) - -instance Applicative (Transaction i) where - pure = Transaction Read ReadCommitted . pure . const . pure - (<*>) = binOp $ \ lSession rSession i -> lSession i <*> rSession i - -instance Alternative (Transaction i) where - empty = retry - (<|>) (Transaction lMode lLevel lList) (Transaction rMode rLevel rList) = - Transaction (max lMode rMode) (max lLevel rLevel) (lList <> rList) - -instance Profunctor Transaction where - dimap fn1 fn2 = map $ \ session -> fmap fn2 . session . fn1 - -instance Strong Transaction where - first' = first - second' = second - -instance Choice Transaction where - left' = left - right' = right - -instance Semigroupoid Transaction where - o = binOp (<=<) - -instance Category Transaction where - id = Transaction Read ReadCommitted [] - (.) = o - -instance Arrow Transaction where - arr fn = Transaction Read ReadCommitted (return (return . fn)) - (***) = binOp $ \ lSession rSession (li, ri) -> (,) <$> lSession li <*> rSession ri - -instance ArrowChoice Transaction where - (+++) = binOp $ \ lSession rSession -> either (fmap Left . lSession) (fmap Right . rSession) - -instance ArrowZero Transaction where - zeroArrow = retry - -instance ArrowPlus Transaction where - (<+>) = (<|>) - -{-| -Because mode and isolation are always composed the same way, -we can focus on composing just the sessions. --} -{-# INLINE binOp #-} -binOp :: - ( - (li -> StateT Condemnation Session lo) -> - (ri -> StateT Condemnation Session ro) -> - (i -> StateT Condemnation Session o) - ) -> - Transaction li lo -> Transaction ri ro -> Transaction i o -binOp composeSessions (Transaction lMode lLevel lList) (Transaction rMode rLevel rList) = let - mode = max lMode rMode - level = max lLevel rLevel - list = composeSessions <$> lList <*> rList - in Transaction mode level list - -{-# INLINE map #-} -map :: - ((i1 -> StateT Condemnation Session o1) -> (i2 -> StateT Condemnation Session o2)) -> - Transaction i1 o1 -> Transaction i2 o2 -map sessionFn (Transaction mode isolation list) = Transaction mode isolation (fmap sessionFn list) - -{-| -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 Read ReadCommitted [\ _ -> put Condemned] - -{-| -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 single statement under a 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 i o -> Transaction i o -statement mode level statement = session mode level $ \ i -> Session.statement i statement - -{-| -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 -> (i -> Session o) -> Transaction i o -session mode level sessionFn = Transaction mode level [lift . sessionFn] - -{-| -Fail the alternation branch, retrying with the other. Same as `empty` and `zeroArrow`. - -Beware that if all your alternatives end up being a retry, -you'll get yourself a perfect infinite loop. --} -retry :: Transaction i o -retry = Transaction Read ReadCommitted [] diff --git a/library/Hasql/Transaction/Types.hs b/library/Hasql/Transaction/Types.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Transaction/Types.hs @@ -0,0 +1,36 @@ +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)