@@ -8,6 +8,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay)
88import Control.Monad (forM_)
99
1010import System.IO (hFlush)
11+import System.IO.Unsafe (unsafePerformIO)
1112import Data.ByteString (ByteString, hPutStr, hGetSome)
1213import qualified Data.ByteString as S
1314import qualified Data.ByteString.Lazy as L
@@ -53,12 +54,18 @@ ignoreBody icount req = do
5354 else err icount ("Invalid request method" :: String, requestMethod req)
5455 return $ responseLBS status200 [] "Ignored the body"
5556
57+nextPort :: I.IORef Int
58+nextPort = unsafePerformIO $ I.newIORef 5000
59+
60+getPort :: IO Int
61+getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
62+
5663runTest :: Int -- ^ expected number of requests
57− -> Int -- ^ port to run on
5864 -> CounterApplication
5965 -> [ByteString] -- ^ chunks to send
6066 -> IO ()
61−runTest expected port app chunks = do
67+runTest expected app chunks = do
68+ port <- getPort
6269 ref <- I.newIORef (Right 0)
6370 tid <- forkIO $ run port $ app ref
6471 threadDelay 1000
@@ -81,24 +88,24 @@ singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\
8188main :: IO ()
8289main = hspecX $ do
8390 describe "non-pipelining" $ do
84− it "no body, read" $ runTest 5 5007 readBody $ replicate 5 singleGet
85− it "no body, ignore" $ runTest 5 5003 ignoreBody $ replicate 5 singleGet
86− it "has body, read" $ runTest 2 5004 readBody
91+ it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet
92+ it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet
93+ it "has body, read" $ runTest 2 readBody
8794 [ singlePostHello
8895 , singleGet
8996 ]
90− it "has body, ignore" $ runTest 2 5005 ignoreBody
97+ it "has body, ignore" $ runTest 2 ignoreBody
9198 [ singlePostHello
9299 , singleGet
93100 ]
94101 describe "pipelining" $ do
95− it "no body, read" $ runTest 5 5006 readBody [S.concat $ replicate 5 singleGet]
96− it "no body, ignore" $ runTest 5 5002 ignoreBody [S.concat $ replicate 5 singleGet]
97− it "has body, read" $ runTest 2 5001 readBody $ return $ S.concat
102+ it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]
103+ it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]
104+ it "has body, read" $ runTest 2 readBody $ return $ S.concat
98105 [ singlePostHello
99106 , singleGet
100107 ]
101− it "has body, ignore" $ runTest 2 5000 ignoreBody $ return $ S.concat
108+ it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat
102109 [ singlePostHello
103110 , singleGet
104111 ]