diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# 0.4.1 +* Fix the transaction conflicts bug diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -11,12 +11,12 @@ import qualified Hasql as H -- Import the backend settings from the "hasql-postgres" library -import qualified Hasql.Postgres as H +import qualified Hasql.Postgres as HP main = do - let postgresSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres" + let postgresSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" -- Prepare session settings with a smart constructor, -- which checks the inputted values on correctness. diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,7 +1,7 @@ name: hasql version: - 0.4.0 + 0.4.1 synopsis: A minimalistic general high level API for relational databases description: @@ -66,6 +66,8 @@ Simple cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md source-repository head @@ -118,11 +120,11 @@ base >= 4.5 && < 4.8 -test-suite tests +test-suite hspec type: exitcode-stdio-1.0 hs-source-dirs: - tests + hspec main-is: Main.hs ghc-options: @@ -134,19 +136,23 @@ default-language: Haskell2010 build-depends: + -- hasql, hasql-backend == 0.2.*, - base-prelude == 0.1.*, - HTF == 0.12.*, - base >= 4.5 && < 4.8 + -- + hspec == 2.1.*, + -- + mtl-prelude < 3, + base-prelude, + base -test-suite postgres-tests - type: +test-suite hspec-postgres + type: exitcode-stdio-1.0 - hs-source-dirs: - postgres-tests - main-is: + hs-source-dirs: + hspec-postgres + main-is: Main.hs ghc-options: -threaded @@ -157,12 +163,19 @@ default-language: Haskell2010 build-depends: + -- hasql, - hasql-postgres == 0.7.*, + hasql-postgres == 0.8.*, + -- + slave-thread == 0.1.*, + -- + hspec == 2.1.*, + -- + text, + -- mtl-prelude < 3, - base-prelude == 0.1.*, - HTF == 0.12.*, - base >= 4.5 && < 4.8 + base-prelude, + base -- Well, it's not a benchmark actually, @@ -184,7 +197,7 @@ Haskell2010 build-depends: hasql, - hasql-postgres == 0.7.*, + hasql-postgres == 0.8.*, transformers >= 0.3 && < 0.5, base >= 4.5 && < 4.8 diff --git a/hspec-postgres/Main.hs b/hspec-postgres/Main.hs new file mode 100644 --- /dev/null +++ b/hspec-postgres/Main.hs @@ -0,0 +1,104 @@ +import BasePrelude +import MTLPrelude +import Test.Hspec +import Data.Text (Text) +import qualified Hasql as H +import qualified Hasql.Postgres as HP +import qualified SlaveThread + + +main = + hspec $ do + + context "Bug" $ do + + context "Unhandled transaction conflict" $ do + + it "should not be" $ do + session $ H.tx Nothing $ do + H.unit [H.q|DROP TABLE IF EXISTS artist|] + H.unit [H.q|DROP TABLE IF EXISTS artist_union|] + H.unit $ + [H.q| + CREATE TABLE "artist_union" ( + "id" BIGSERIAL, + PRIMARY KEY ("id") + ) + |] + H.unit $ + [H.q| + CREATE TABLE "artist" ( + "id" BIGSERIAL, + "artist_union_id" INT8 NOT NULL, + "names" TEXT[] NOT NULL, + PRIMARY KEY ("id"), + FOREIGN KEY ("artist_union_id") REFERENCES "artist_union" ("id") ON DELETE CASCADE + ) + |] + (signal, block) <- newBatchGate 6 + let + insertArtistUnion :: H.Tx HP.Postgres s Int64 + insertArtistUnion = + fmap (runIdentity . fromJust) $ H.single $ + [H.q| + INSERT INTO artist_union DEFAULT VALUES RETURNING id + |] + insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64 + insertArtist unionID artistNames = + fmap (runIdentity . fromJust) $ H.single $ + [H.q| + INSERT INTO artist + (artist_union_id, + names) + VALUES (?, ?) + RETURNING id + |] + unionID + artistNames + process = + SlaveThread.fork $ do + session $ replicateM_ 100 $ do + H.tx (Just (H.Serializable, True)) $ do + unionID <- insertArtistUnion + insertArtist unionID ["a", "b", "c"] + signal + replicateM_ 6 process + block + + context "RowParser" $ do + + it "should fail on incorrect arity" $ do + flip shouldThrow (\case H.UnparsableRow _ -> True; _ -> False) $ + session $ do + H.tx Nothing $ do + H.unit [H.q|DROP TABLE IF EXISTS data|] + H.unit [H.q|CREATE TABLE data ( + field1 DECIMAL NOT NULL, + field2 BIGINT NOT NULL, + PRIMARY KEY (field1) + )|] + H.unit [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|] + mrow :: Maybe (Double, Int64, String) <- + H.tx Nothing $ + H.single $ [H.q|SELECT * FROM data|] + return () + + +-- * Helpers +------------------------- + +session :: (forall s. H.Session HP.Postgres s IO r) -> IO r +session = + H.session backendSettings poolSettings + where + backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" + poolSettings = fromJust $ H.sessionSettings 6 30 + +newBatchGate :: Int -> IO (IO (), IO ()) +newBatchGate amount = + do + counter <- atomically $ newTVar amount + return $ + let signal = atomically $ readTVar counter >>= writeTVar counter . pred + block = atomically $ readTVar counter >>= \x -> when (x > 0) retry + in (signal, block) diff --git a/hspec/Main.hs b/hspec/Main.hs new file mode 100644 --- /dev/null +++ b/hspec/Main.hs @@ -0,0 +1,22 @@ +import BasePrelude +import Test.Hspec +import qualified Hasql as H +import qualified Hasql.Backend as HB + + +data X +instance HB.Backend X where + data StatementArgument X = + StatementArgument String + deriving (Eq, Show) +instance HB.Mapping X Char where + renderValue = StatementArgument . show + + +main = + hspec $ do + context "Quasi quoter" $ do + it "generates a proper statement" $ do + (flip shouldBe) + (" SELECT ? ", [HB.renderValue 'a'], True) + ([H.q| SELECT ? |] 'a' :: HB.Statement X) diff --git a/library/Hasql.hs b/library/Hasql.hs --- a/library/Hasql.hs +++ b/library/Hasql.hs @@ -249,16 +249,16 @@ Backend b => Backend.TransactionMode -> Backend.Connection b -> IO r -> IO r inTransaction mode c io = - do - Backend.beginTransaction mode c - try io >>= \case - Left Backend.TransactionConflict -> do - Backend.finishTransaction False c - inTransaction mode c io - Left e -> throwIO e - Right r -> do - Backend.finishTransaction True c - return r + let + io' = + Backend.beginTransaction mode c *> io <* Backend.finishTransaction True c + in + try io' >>= \case + Left Backend.TransactionConflict -> do + Backend.finishTransaction False c + inTransaction mode c io + Left e -> throwIO e + Right r -> return r -- * Results Stream diff --git a/postgres-tests/Main.hs b/postgres-tests/Main.hs deleted file mode 100644 --- a/postgres-tests/Main.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} -import BasePrelude -import MTLPrelude -import Test.Framework -import qualified Hasql as H -import qualified Hasql.Postgres as HP - - -main = - htfMain $ htf_thisModulesTests - -test_wrongRowParserArity = - flip assertThrowsIO (\case H.UnparsableRow _ -> True; _ -> False) $ - session $ do - H.tx Nothing $ do - H.unit [H.q|DROP TABLE IF EXISTS data|] - H.unit [H.q|CREATE TABLE data ( - field1 DECIMAL NOT NULL, - field2 BIGINT NOT NULL, - PRIMARY KEY (field1) - )|] - H.unit [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|] - mrow :: Maybe (Double, Int64, String) <- - H.tx Nothing $ - H.single $ [H.q|SELECT * FROM data|] - return () - - -session :: (forall s. H.Session HP.Postgres s IO r) -> IO r -session = - H.session backendSettings poolSettings - where - backendSettings = HP.Postgres "localhost" 5432 "postgres" "" "postgres" - poolSettings = fromJust $ H.sessionSettings 6 30 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} -import BasePrelude -import Test.Framework -import qualified Hasql as H -import qualified Hasql.Backend as HB - -main = - htfMain $ htf_thisModulesTests - -data X -instance HB.Backend X where - data StatementArgument X = - StatementArgument String - deriving (Eq, Show) -instance HB.Mapping X Char where - renderValue = StatementArgument . show - - -test_quasiQuoterGeneratesAProperStatement = - assertEqual - (" SELECT ? ", [HB.renderValue 'a'], True) - ([H.q| SELECT ? |] 'a' :: HB.Statement X)