diff --git a/hasql.cabal b/hasql.cabal index d19af5e..c1ff540 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -167,8 +167,12 @@ test-suite hspec-postgres hasql, hasql-postgres == 0.8.*, -- + slave-thread == 0.1.*, + -- hspec == 2.1.*, -- + text, + -- mtl-prelude < 3, base-prelude, base diff --git a/hspec-postgres/Main.hs b/hspec-postgres/Main.hs index 2d3005d..8a72c6a 100644 --- a/hspec-postgres/Main.hs +++ b/hspec-postgres/Main.hs @@ -1,13 +1,70 @@ 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 @@ -27,9 +84,21 @@ main = 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)