Add concurrent test for "transaction in progress"

MonadBaseControl wizardry courtesy of @jwiegley

test/Feature/ConcurrentSpec.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Feature.ConcurrentSpec where
+
+import Control.Monad (void)
+import Control.Monad.Base
+
+import Control.Monad.Trans.Control
+import Control.Concurrent.Async (mapConcurrently)
+
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai.Internal
+import Test.Hspec.Wai
+import Network.Wai.Test (Session)
+import qualified Hasql.Connection  as H
+
+import SpecHelper
+import PostgREST.Types (DbStructure(..))
+
+spec :: DbStructure -> H.Connection -> Spec
+spec struct c = around (withApp cfgDefault struct c) $
+
+  describe "Queryiny in parallel" $
+    it "should not raise 'transaction in progress' error" $
+      raceTest 3 $
+        get "/fakefake" `shouldRespondWith` 404
+
+raceTest :: Int -> WaiExpectation -> WaiExpectation
+raceTest times = liftBaseDiscard go
+ where
+  go test = void $ mapConcurrently (const test) [1..times]
+
+instance MonadBaseControl IO WaiSession where
+  type StM WaiSession a = StM Session a
+  liftBaseWith f = WaiSession $
+    liftBaseWith $ \runInBase ->
+      f $ \k -> runInBase (unWaiSession k)
+  restoreM = WaiSession . restoreM
+  {-# INLINE liftBaseWith #-}
+  {-# INLINE restoreM #-}
+
+instance MonadBase IO WaiSession where
+  liftBase = liftIO

test/Main.hs

@@ -10,6 +10,7 @@ import PostgREST.DbStructure (getDbStructure)
 import Data.String.Conversions (cs)
 
 import qualified Feature.AuthSpec
+import qualified Feature.ConcurrentSpec
 import qualified Feature.CorsSpec
 import qualified Feature.DeleteSpec
 import qualified Feature.InsertSpec
@@ -34,6 +35,7 @@ main = do
  where
   specs conn dbStructure = do
     describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn
+    describe "Feature.ConcurrentSpec" $ Feature.ConcurrentSpec.spec dbStructure conn
     describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn
     describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn
     describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn