Doing a parallel load test

[begriffs]

A user discovered a problem in my web server that causes it to freeze under certain types of concurrent traffic. I'm trying to model the situation in a test but having trouble with the types.

import Control.Concurrent.Async (mapConcurrently)
-- ...

context "in parallel, contentiously" $ do
  it "does not crash the server" $ do
    liftIO $ mapConcurrently (
        const . void $ get "/foo"
      ) [1..100]
    get "/bar" `shouldRespondWith` 200

My problem is that once I'm inside of the concurrent map I'm in IO and I don't know how to get back into WaiSession in order to make a get request. Is it possible to do this?

[gregwebs]

You will need to run your monad stack. Here is one for Yesod's test monad.

-- | Lifted version of 'mapConcurrently'.  The state from
-- of all inner computations are discarded.
mapConcurrentlyTest :: Traversable t => (a -> YesodExample site b) -> t a -> YesodExample site (t b)
mapConcurrentlyTest f xs =
  StateT $ \s -> (, s) <$> mapConcurrently (\x -> evalStateT (f x) s) xs

[sol]

@begriffs sorry for replying late. By default hspec-wai tests WAI applications in-memory, without opening any TCP ports. For your situation you may want to test your application through a real HTTP server (say warp). I have some wip code (see #31) that allows this. With this I think you can do what you want:

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import           Test.Hspec
import           Test.Hspec.Wai
import           Test.Hspec.Wai.Http (withServer)
import           Test.Hspec.Wai.Internal
import           Control.Monad.Trans.Reader
import           Control.Concurrent.Async

import           Network.Wai (Application)
import qualified Web.Scotty as S

main :: IO ()
main = hspec spec

app :: IO Application
app = S.scottyApp $ do
  S.get "/foo" $ do
    S.text "hello"

spec :: Spec
spec = withServer app $ do
  describe "GET /" $ do
    it "can handle concurrent requests" $ do
      req <- WaiSession ask
      xs <- liftIO $ do
        mapConcurrently (const $ req "GET" "/foo" [] "") [1..100]
      mapM_ ((`shouldRespondWith` "hello") . return) xs

I don't have many free cycles I can spent on #31, help would be much welcome.

[begriffs]

@jwiegley found another way to do this:

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

This allows me to make a test like this

concurrently :: Int -> WaiExpectation -> WaiExpectation
concurrently times = liftBaseDiscard go
 where
  go test = void $ mapConcurrently (const test) [1..times]

spec :: SpecWith Application
spec =
  describe "Queryiny in parallel" $
    it "gets lots of foo" $
      concurrently 10 $
        get "/foo" `shouldRespondWith` 200

Right now the MonadBaseControl and MonadBase instances are orphans in my code, could you add them to hspec-wai?