Robert VollmertandSteve Chavez
79399686db
The changes here are from fixing stack build with LTS 15.8 (GHC 8.8.3) to be warning-free. Most if not all come from the newer protolude version, which adds some things like `unwords`. So to make sure that we don't get unused import warnings with newer stackage, this both raises the protolude lower bound and removes these imports.
53 lines
1.5 KiB
Haskell
53 lines
1.5 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Feature.ConcurrentSpec where
|
|
|
|
import Control.Concurrent.Async (mapConcurrently)
|
|
import Network.Wai (Application)
|
|
|
|
import Control.Monad.Base
|
|
import Control.Monad.Trans.Control
|
|
|
|
import Network.Wai.Test (Session)
|
|
import Test.Hspec
|
|
import Test.Hspec.Wai
|
|
import Test.Hspec.Wai.Internal
|
|
import Test.Hspec.Wai.JSON
|
|
|
|
import Protolude hiding (get)
|
|
|
|
spec :: SpecWith ((), Application)
|
|
spec =
|
|
describe "Querying in parallel" $
|
|
it "should not raise 'transaction in progress' error" $
|
|
raceTest 10 $
|
|
get "/fakefake"
|
|
`shouldRespondWith` [json|
|
|
{ "hint": null,
|
|
"details":null,
|
|
"code":"42P01",
|
|
"message":"relation \"test.fakefake\" does not exist"
|
|
} |]
|
|
{ matchStatus = 404
|
|
, matchHeaders = []
|
|
}
|
|
|
|
raceTest :: Int -> WaiExpectation st -> WaiExpectation st
|
|
raceTest times = liftBaseDiscard go
|
|
where
|
|
go test = void $ mapConcurrently (const test) [1..times]
|
|
|
|
instance MonadBaseControl IO (WaiSession st) where
|
|
type StM (WaiSession st) 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 st) where
|
|
liftBase = liftIO
|