Merge branch '0.4'

* 0.4:
  Release
  Fix the bug
  Reproduce the bug in a test
  Switch to the "hspec" testing framework
  Begin a changes log (#18)
  Update Demo

CHANGELOG.md

@@ -0,0 +1,2 @@
+# 0.4.1
+* Fix the transaction conflicts bug

demo/Main.hs

@@ -11,12 +11,12 @@ import Data.Functor.Identity
 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

@@ -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 @@ build-type:
   Simple
 cabal-version:
   >=1.10
+extra-source-files:
+  CHANGELOG.md
 
 
 source-repository head
@@ -118,11 +120,11 @@ library
     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 @@ test-suite tests
   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 @@ test-suite postgres-tests
   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 @@ benchmark demo
     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

@@ -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

@@ -1,11 +1,8 @@
-{-# OPTIONS_GHC -F -pgmF htfpp #-}
 import BasePrelude
-import Test.Framework
+import Test.Hspec
 import qualified Hasql as H
 import qualified Hasql.Backend as HB
 
-main = 
-  htfMain $ htf_thisModulesTests
 
 data X
 instance HB.Backend X where
@@ -16,7 +13,10 @@ instance HB.Mapping X Char where
   renderValue = StatementArgument . show
 
 
-test_quasiQuoterGeneratesAProperStatement =
-  assertEqual 
-    (" SELECT ? ", [HB.renderValue 'a'], True)
-    ([H.q| SELECT ? |] 'a' :: HB.Statement X)
+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

@@ -250,16 +250,16 @@ tx m t =
           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