From 4f23fe590885e1af5f5c7e6b97bf73365bf96b82 Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Sun, 6 Mar 2016 13:44:56 +0300
Subject: [PATCH] Add threads test

---
 hasql.cabal                  | 24 +++++++++++++++++++
 threads-test/Main.hs         | 45 ++++++++++++++++++++++++++++++++++++
 threads-test/Main/Queries.hs | 20 ++++++++++++++++
 3 files changed, 89 insertions(+)
 create mode 100644 threads-test/Main.hs
 create mode 100644 threads-test/Main/Queries.hs

diff --git a/hasql.cabal b/hasql.cabal
index c2c34d9..4ee6f46 100644
--- a/hasql.cabal
+++ b/hasql.cabal
@@ -138,6 +138,30 @@ test-suite tasty
     rebase
 
 
+test-suite threads-test
+  type:
+    exitcode-stdio-1.0
+  hs-source-dirs:
+    threads-test
+  main-is:
+    Main.hs
+  other-modules:
+    Main.Queries
+  ghc-options:
+    -O2
+    -threaded
+    "-with-rtsopts=-N"
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+  build-depends:
+    -- database:
+    hasql,
+    -- base,
+    rebase
+
+
 benchmark benchmark
   type: 
     exitcode-stdio-1.0
diff --git a/threads-test/Main.hs b/threads-test/Main.hs
new file mode 100644
index 0000000..93ca7f5
--- /dev/null
+++ b/threads-test/Main.hs
@@ -0,0 +1,45 @@
+module Main where
+
+import Rebase.Prelude
+import qualified Hasql.Connection
+import qualified Hasql.Query
+import qualified Hasql.Encoders
+import qualified Hasql.Decoders
+import qualified Hasql.Session
+import qualified Main.Queries as Queries
+
+
+main =
+  acquire >>= use
+  where
+    acquire =
+      (,) <$> acquire <*> acquire
+      where
+        acquire =
+          join $
+          fmap (either (fail . show) return) $
+          Hasql.Connection.acquire connectionSettings
+          where
+            connectionSettings =
+              Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"
+    use (connection1, connection2) =
+      do
+        beginVar <- newEmptyMVar
+        finishVar <- newEmptyMVar
+        forkIO $ do
+          traceM "1: in"
+          putMVar beginVar ()
+          session connection1 (Hasql.Session.query 0.2 Queries.selectSleep)
+          traceM "1: out"
+          void (tryPutMVar finishVar False)
+        forkIO $ do
+          takeMVar beginVar
+          traceM "2: in"
+          session connection2 (Hasql.Session.query 0.1 Queries.selectSleep)
+          traceM "2: out"
+          void (tryPutMVar finishVar True)
+        bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar
+      where
+        session connection session =
+          Hasql.Session.run session connection >>=
+          either (fail . show) return
diff --git a/threads-test/Main/Queries.hs b/threads-test/Main/Queries.hs
new file mode 100644
index 0000000..1ca2bba
--- /dev/null
+++ b/threads-test/Main/Queries.hs
@@ -0,0 +1,20 @@
+module Main.Queries where
+
+import Rebase.Prelude
+import Hasql.Query
+import qualified Hasql.Encoders as E
+import qualified Hasql.Decoders as D
+
+
+selectSleep :: Query Double ()
+selectSleep =
+  statement sql encoder decoder True
+  where
+    sql =
+      "select pg_sleep($1)"
+    encoder =
+      E.value E.float8
+    decoder =
+      D.unit
+
+