hasql-transaction 0.4.5.1 → 0.5

raw patch · 13 files changed

+312/−255 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• conflicts-test/Main.hs +49/−33
• conflicts-test/Main/Transactions.hs +10/−7
• hasql-transaction.cabal +8/−3
• library/Hasql/Transaction.hs +5/−93
• library/Hasql/Transaction/Prelude.hs +0/−40
• library/Hasql/Transaction/Private/Model.hs +25/−0
• library/Hasql/Transaction/Private/Prelude.hs +40/−0
• library/Hasql/Transaction/Private/Queries.hs +50/−0
• library/Hasql/Transaction/Private/SQL.hs +29/−0
• library/Hasql/Transaction/Private/Sessions.hs +29/−0
• library/Hasql/Transaction/Private/Transaction.hs +50/−0
• library/Hasql/Transaction/Queries.hs +0/−79
• library/Hasql/Transaction/Sessions.hs +17/−0

@@ -1,12 +1,13 @@ module Main where  import Rebase.Prelude-import qualified Hasql.Connection as Connection-import qualified Hasql.Session as Session-import qualified Hasql.Transaction as Transaction-import qualified Main.Queries as Queries-import qualified Main.Transactions as Transactions-import qualified Control.Concurrent.Async as Async+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.Queries as D+import qualified Main.Transactions as E+import qualified Control.Concurrent.Async as F   main =@@ -18,19 +19,19 @@         acquire =           join $           fmap (either (fail . show) return) $-          Connection.acquire connectionSettings+          A.acquire connectionSettings           where             connectionSettings =-              Connection.settings "localhost" 5432 "postgres" "" "postgres"+              A.settings "localhost" 5432 "postgres" "" "postgres"     release (connection1, connection2) =       do-        transaction connection1 Transactions.dropSchema-        Connection.release connection1-        Connection.release connection2+        transaction connection1 E.dropSchema+        A.release connection1+        A.release connection2     use (connection1, connection2) =       do-        try (transaction connection1 Transactions.dropSchema) :: IO (Either SomeException ())-        transaction connection1 Transactions.createSchema+        try (transaction connection1 E.dropSchema) :: IO (Either SomeException ())+        transaction connection1 E.createSchema         success <- fmap and (traverse runTest tests)         if success           then exitSuccess@@ -39,46 +40,61 @@         runTest test =           test connection1 connection2         tests =-          [transactionsTest, transactionAndQueryTest]+          [readAndWriteTransactionsTest, transactionsTest, transactionAndQueryTest]   session connection session =-  Session.run session connection >>=+  B.run session connection >>=   either (fail . show) return  transaction connection transaction =-  session connection (Transaction.run transaction Transaction.RepeatableRead Transaction.Write)+  session connection (G.transaction C.RepeatableRead C.Write transaction)   type Test =-  Connection.Connection -> Connection.Connection -> IO Bool+  A.Connection -> A.Connection -> IO Bool  transactionsTest :: Test transactionsTest connection1 connection2 =   do-    id1 <- session connection1 (Session.query 0 Queries.createAccount)-    id2 <- session connection1 (Session.query 0 Queries.createAccount)-    async1 <- Async.async (replicateM_ 1000 (transaction connection1 (Transactions.transfer id1 id2 1)))-    async2 <- Async.async (replicateM_ 1000 (transaction connection2 (Transactions.transfer id1 id2 1)))-    Async.wait async1-    Async.wait async2-    balance1 <- session connection1 (Session.query id1 Queries.getBalance)-    balance2 <- session connection1 (Session.query id2 Queries.getBalance)+    id1 <- session connection1 (B.query 0 D.createAccount)+    id2 <- session connection1 (B.query 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.query id1 D.getBalance)+    balance2 <- session connection1 (B.query id2 D.getBalance)     traceShowM balance1     traceShowM balance2     return (balance1 == Just 2000 && balance2 == Just (-2000)) +readAndWriteTransactionsTest :: Test+readAndWriteTransactionsTest connection1 connection2 =+  do+    id1 <- session connection1 (B.query 0 D.createAccount)+    id2 <- session connection1 (B.query 0 D.createAccount)+    async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1)))+    async2 <- F.async (replicateM_ 1000 (transaction connection2 (C.query id1 D.getBalance)))+    F.wait async1+    F.wait async2+    balance1 <- session connection1 (B.query id1 D.getBalance)+    balance2 <- session connection1 (B.query id2 D.getBalance)+    traceShowM balance1+    traceShowM balance2+    return (balance1 == Just 1000 && balance2 == Just (-1000))+ transactionAndQueryTest :: Test transactionAndQueryTest connection1 connection2 =   do-    id1 <- session connection1 (Session.query 0 Queries.createAccount)-    id2 <- session connection1 (Session.query 0 Queries.createAccount)-    async1 <- Async.async (transaction connection1 (Transactions.transferTimes 200 id1 id2 1))-    async2 <- Async.async (session connection2 (replicateM_ 200 (Session.query (id1, 1) Queries.modifyBalance)))-    Async.wait async1-    Async.wait async2-    balance1 <- session connection1 (Session.query id1 Queries.getBalance)-    balance2 <- session connection1 (Session.query id2 Queries.getBalance)+    id1 <- session connection1 (B.query 0 D.createAccount)+    id2 <- session connection1 (B.query 0 D.createAccount)+    async1 <- F.async (transaction connection1 (E.transferTimes 200 id1 id2 1))+    async2 <- F.async (session connection2 (replicateM_ 200 (B.query (id1, 1) D.modifyBalance)))+    F.wait async1+    F.wait async2+    balance1 <- session connection1 (B.query id1 D.getBalance)+    balance2 <- session connection1 (B.query id2 D.getBalance)     traceShowM balance1     traceShowM balance2     return (balance1 == Just 400 && balance2 == Just (-200))

@@ -2,25 +2,28 @@  import Rebase.Prelude import Hasql.Transaction-import qualified Main.Queries as Queries+import qualified Main.Queries as A   createSchema :: Transaction () createSchema =   do-    query () Queries.createAccountTable+    query () A.createAccountTable  dropSchema :: Transaction () dropSchema =   do-    query () Queries.dropAccountTable+    query () A.dropAccountTable -transfer :: Int64 -> Int64 -> Scientific -> Transaction ()+transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool transfer id1 id2 amount =   do-    query (id1, amount) Queries.modifyBalance-    query (id2, negate amount) Queries.modifyBalance-    return ()+    success <- query (id1, amount) A.modifyBalance+    if success+      then+        query (id2, negate amount) A.modifyBalance+      else+        return False  transferTimes :: Int -> Int64 -> Int64 -> Scientific -> Transaction () transferTimes times id1 id2 amount =

@@ -1,7 +1,7 @@ name:   hasql-transaction version:-  0.4.5.1+  0.5 category:   Hasql, Database, PostgreSQL synopsis:@@ -42,10 +42,15 @@   default-language:     Haskell2010   other-modules:-    Hasql.Transaction.Prelude-    Hasql.Transaction.Queries+    Hasql.Transaction.Private.Prelude+    Hasql.Transaction.Private.Model+    Hasql.Transaction.Private.SQL+    Hasql.Transaction.Private.Queries+    Hasql.Transaction.Private.Sessions+    Hasql.Transaction.Private.Transaction   exposed-modules:     Hasql.Transaction+    Hasql.Transaction.Sessions   build-depends:     -- database:     hasql >= 0.17 && < 0.20,

@@ -1,3 +1,5 @@+-- |+-- An API for declaration of transactions. module Hasql.Transaction (   -- * Transaction settings@@ -5,101 +7,11 @@   IsolationLevel(..),   -- * Transaction monad   Transaction,-  run,+  condemn,   sql,   query, ) where -import Hasql.Transaction.Prelude-import qualified Hasql.Query as Query-import qualified Hasql.Session as Session-import qualified Hasql.Transaction.Queries as Queries----- |--- 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 (Session.Session a)-  deriving (Functor, Applicative, Monad)---- |--- -data Mode =-  -- |-  -- Read-only. No writes possible.-  Read |-  -- |-  -- Write and commit.-  Write |-  -- |-  -- Write without committing.-  -- Useful for testing, -  -- allowing you to modify your database, -  -- producing some result based on your changes,-  -- and letting Hasql roll all the changes back on the exit from the transaction.-  WriteWithoutCommitting-  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)---- |--- Execute the transaction using the provided isolation level and mode.-{-# INLINABLE run #-}-run :: Transaction a -> IsolationLevel -> Mode -> Session.Session a-run (Transaction session) isolation mode =-  fix $-  \ recur ->-    do-      resultEither <- do-        Session.query () (Queries.beginTransaction mode')-        tryError $ do-          result <- session-          Session.query () (bool Queries.abortTransaction Queries.commitTransaction commit)-          return result-      case resultEither of-        Left error -> do-          Session.query () Queries.abortTransaction-          case error of-            Session.ResultError (Session.ServerError "40001" _ _ _) ->-              recur-            _ -> -              throwError error-        Right result -> do-          pure result-  where-    mode' =-      (unsafeCoerce isolation, write)-    (write, commit) =-      case mode of-        Read -> (False, True)-        Write -> (True, True)-        WriteWithoutCommitting -> (True, False)---- |--- 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 sql =-  Transaction $ Session.sql sql---- |--- Parameters and a specification of the parametric query to apply them to.-{-# INLINE query #-}-query :: a -> Query.Query a b -> Transaction b-query params query =-  Transaction $ Session.query params query+import Hasql.Transaction.Private.Transaction+import Hasql.Transaction.Private.Model

@@ -1,40 +0,0 @@-module Hasql.Transaction.Prelude-( -  module Exports,-  tryError,-)-where----- base-prelude---------------------------import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)---- transformers---------------------------import Control.Monad.IO.Class as Exports-import Control.Monad.Trans.Class as Exports-import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass)-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)---- mtl---------------------------import Control.Monad.Error.Class as Exports (MonadError (..))---- contravariant---------------------------import Data.Functor.Contravariant as Exports-import Data.Functor.Contravariant.Divisible as Exports---- contravariant-extras---------------------------import Contravariant.Extras as Exports---- bytestring---------------------------import Data.ByteString as Exports (ByteString)--tryError :: MonadError e m => m a -> m (Either e a)-tryError m =-  catchError (liftM Right m) (return . Left)

@@ -0,0 +1,25 @@+module Hasql.Transaction.Private.Model+where++import Hasql.Transaction.Private.Prelude++-- |+--+data Mode =+  -- |+  -- Read-only. No writes possible.+  Read |+  -- |+  -- Write and commit.+  Write+  deriving (Show, Eq, Ord, Enum, Bounded)++-- |+-- For reference see+-- <http://www.postgresql.org/docs/current/static/transaction-iso.html the Postgres' documentation>.+--+data IsolationLevel =+  ReadCommitted |+  RepeatableRead |+  Serializable+  deriving (Show, Eq, Ord, Enum, Bounded)

@@ -0,0 +1,40 @@+module Hasql.Transaction.Private.Prelude+( +  module Exports,+  tryError,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)++-- transformers+-------------------------+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)++-- mtl+-------------------------+import Control.Monad.Error.Class as Exports (MonadError (..))++-- contravariant+-------------------------+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports++-- contravariant-extras+-------------------------+import Contravariant.Extras as Exports++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++tryError :: MonadError e m => m a -> m (Either e a)+tryError m =+  catchError (liftM Right m) (return . Left)

@@ -0,0 +1,50 @@+module Hasql.Transaction.Private.Queries+where++import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Model+import qualified Hasql.Query as A+import qualified Hasql.Encoders as B+import qualified Hasql.Decoders as C+import qualified Hasql.Transaction.Private.SQL as D+++-- * Transactions+-------------------------++beginTransaction :: IsolationLevel -> Mode -> A.Query () ()+beginTransaction isolation mode =+  A.statement (D.beginTransaction isolation mode) B.unit C.unit True++commitTransaction :: A.Query () ()+commitTransaction =+  A.statement "COMMIT" B.unit C.unit True++abortTransaction :: A.Query () ()+abortTransaction =+  A.statement "ABORT" B.unit C.unit True+++-- * Streaming+-------------------------++declareCursor :: ByteString -> ByteString -> B.Params a -> A.Query a ()+declareCursor name sql encoder =+  A.statement (D.declareCursor name sql) encoder C.unit False++closeCursor :: A.Query ByteString ()+closeCursor =+  A.statement "CLOSE $1" (B.value B.bytea) C.unit True++fetchFromCursor :: (b -> a -> b) -> b -> C.Row a -> A.Query (Int64, ByteString) b+fetchFromCursor step init rowDec =+  A.statement sql encoder decoder True+  where+    sql =+      "FETCH FORWARD $1 FROM $2"+    encoder =+      contrazip2+        (B.value B.int8)+        (B.value B.bytea)+    decoder =+      C.foldlRows step init rowDec

@@ -0,0 +1,29 @@+module Hasql.Transaction.Private.SQL+where++import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Model+import qualified ByteString.TreeBuilder as D+++beginTransaction :: IsolationLevel -> Mode -> ByteString+beginTransaction isolation mode =+  D.toByteString builder+  where+    builder =+      "BEGIN " <> isolationBuilder <> " " <> modeBuilder+      where+        isolationBuilder =+          case isolation of+            ReadCommitted -> "ISOLATION LEVEL READ COMMITTED"+            RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"+            Serializable -> "ISOLATION LEVEL SERIALIZABLE"+        modeBuilder =+          case mode of+            Write -> "READ WRITE"+            Read -> "READ ONLY"++declareCursor :: ByteString -> ByteString -> ByteString+declareCursor name sql =+  D.toByteString $+  "DECLARE " <> D.byteString name <> " NO SCROLL CURSOR FOR " <> D.byteString sql

@@ -0,0 +1,29 @@+module Hasql.Transaction.Private.Sessions+where++import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Model+import qualified Hasql.Session as A+import qualified Hasql.Transaction.Private.Queries as B+++inRetryingTransaction :: IsolationLevel -> Mode -> A.Session (a, Bool) -> A.Session a+inRetryingTransaction isolation mode session =+  fix $ \recur -> catchError normal (onError recur)+  where+    normal =+      do+        A.query () (B.beginTransaction isolation mode)+        (result, commit) <- session+        if commit+          then A.query () B.commitTransaction+          else A.query () B.abortTransaction+        return result+    onError continue error =+      do+        A.query () B.abortTransaction+        case error of+          A.ResultError (A.ServerError "40001" _ _ _) ->+            continue+          _ ->+            throwError error

@@ -0,0 +1,50 @@+module Hasql.Transaction.Private.Transaction+where++import Hasql.Transaction.Private.Prelude+import Hasql.Transaction.Private.Model+import qualified Hasql.Query as A+import qualified Hasql.Session as B+import qualified Hasql.Transaction.Private.Queries as C+import qualified Hasql.Transaction.Private.Sessions as D+++-- |+-- A composable abstraction over the retryable transactions.+--+-- Executes multiple queries under the specified mode and isolation level,+-- while automatically retrying the transaction in case of conflicts.+-- Thus this abstraction closely reproduces the behaviour of 'STM'.+newtype Transaction a =+  Transaction (StateT Bool B.Session a)+  deriving (Functor, Applicative, Monad)++-- |+-- Execute the transaction using the provided isolation level and mode.+{-# INLINE run #-}+run :: Transaction a -> IsolationLevel -> Mode -> B.Session a+run (Transaction session) isolation mode =+  D.inRetryingTransaction isolation mode (runStateT session True)++-- |+-- Possibly a multi-statement query,+-- which however cannot be parameterized or prepared,+-- nor can any results of it be collected.+{-# INLINE sql #-}+sql :: ByteString -> Transaction ()+sql =+  Transaction . lift . B.sql++-- |+-- Parameters and a specification of the parametric query to apply them to.+{-# INLINE query #-}+query :: a -> A.Query a b -> Transaction b+query params query =+  Transaction . lift $ B.query params query++-- |+-- Cause transaction to eventually roll back.+{-# INLINE condemn #-}+condemn :: Transaction ()+condemn =+  Transaction $ put False

@@ -1,79 +0,0 @@-module Hasql.Transaction.Queries-where--import Hasql.Transaction.Prelude-import qualified Hasql.Query as HQ-import qualified Hasql.Encoders as HE-import qualified Hasql.Decoders as HD-import qualified ByteString.TreeBuilder as TB----- * Transactions----------------------------data Isolation =-  ReadCommitted |-  RepeatableRead |-  Serializable --type TransactionMode =-  (Isolation, Bool)--beginTransaction :: TransactionMode -> HQ.Query () ()-beginTransaction (isolation, write) =-  HQ.statement sql HE.unit HD.unit True-  where-    sql =-      TB.toByteString $-      mconcat $-      [-        "BEGIN "-        ,-        case isolation of-          ReadCommitted  -> "ISOLATION LEVEL READ COMMITTED"-          RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"-          Serializable   -> "ISOLATION LEVEL SERIALIZABLE"-        ,-        " "-        ,-        case write of-          True  -> "READ WRITE"-          False -> "READ ONLY"-      ]--commitTransaction :: HQ.Query () ()-commitTransaction =-  HQ.statement "commit" HE.unit HD.unit True--abortTransaction :: HQ.Query () ()-abortTransaction =-  HQ.statement "abort" HE.unit HD.unit True----- * Streaming----------------------------declareCursor :: ByteString -> ByteString -> HE.Params a -> HQ.Query a ()-declareCursor name sql encoder =-  HQ.statement sql' encoder HD.unit False-  where-    sql' =-      TB.toByteString $-      "DECLARE " <> TB.byteString name <> " NO SCROLL CURSOR FOR " <> TB.byteString sql--closeCursor :: HQ.Query ByteString ()-closeCursor =-  HQ.statement "CLOSE $1" (HE.value HE.bytea) HD.unit True--fetchFromCursor :: (b -> a -> b) -> b -> HD.Row a -> HQ.Query (Int64, ByteString) b-fetchFromCursor step init rowDec =-  HQ.statement sql encoder decoder True-  where-    sql =-      "FETCH FORWARD $1 FROM $2"-    encoder =-      contrazip2-        (HE.value HE.int8)-        (HE.value HE.bytea)-    decoder =-      HD.foldlRows step init rowDec

@@ -0,0 +1,17 @@+module Hasql.Transaction.Sessions+(+  transaction,+)+where++import qualified Hasql.Transaction.Private.Transaction as A+import qualified Hasql.Session as B+import qualified Hasql.Transaction.Private.Model as C+++-- |+-- 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