Add concurrent test for "transaction in progress"

MonadBaseControl wizardry courtesy of @jwiegley

postgrest.cabal

@@ -127,6 +127,7 @@ Test-Suite spec
   Hs-Source-Dirs:      test, src
   Main-Is:             Main.hs
   Other-Modules:       Feature.AuthSpec
+                     , Feature.ConcurrentSpec
                      , Feature.CorsSpec
                      , Feature.DeleteSpec
                      , Feature.InsertSpec
@@ -148,6 +149,7 @@ Test-Suite spec
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson
+                     , async
                      , base
                      , base64-string
                      , bytestring
@@ -164,6 +166,7 @@ Test-Suite spec
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
+                     , monad-control
                      , optparse-applicative
                      , parsec
                      , process
@@ -173,6 +176,8 @@ Test-Suite spec
                      , string-conversions
                      , text
                      , time
+                     , transformers
+                     , transformers-base
                      , unordered-containers
                      , vector
                      , wai

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