hasql 0.4.0 → 0.4.1
raw patch · 8 files changed
+169/−84 lines, 8 filesdep +hspecdep +slave-threaddep −HTFdep ~basedep ~base-preludedep ~hasql-postgresPVP ok
version bump matches the API change (PVP)
Dependencies added: hspec, slave-thread
Dependencies removed: HTF
Dependency ranges changed: base, base-prelude, hasql-postgres, text
API changes (from Hackage documentation)
Files
- CHANGELOG.md +2/−0
- demo/Main.hs +2/−2
- hasql.cabal +29/−16
- hspec-postgres/Main.hs +104/−0
- hspec/Main.hs +22/−0
- library/Hasql.hs +10/−10
- postgres-tests/Main.hs +0/−34
- tests/Main.hs +0/−22
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# 0.4.1+* Fix the transaction conflicts bug
demo/Main.hs view
@@ -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.
hasql.cabal view
@@ -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
+ hspec-postgres/Main.hs view
@@ -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)
+ hspec/Main.hs view
@@ -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)
library/Hasql.hs view
@@ -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
− postgres-tests/Main.hs
@@ -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
− tests/Main.hs
@@ -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)