@@ -18,6 +18,8 @@ import Network.Wai.Handler.Warp
1818import System.IO (hFlush, hClose)
1919import System.IO.Unsafe (unsafePerformIO)
2020import Test.Hspec
21+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
22+import Control.Exception (bracket)
2123
2224main :: IO ()
2325main = hspec spec
@@ -68,24 +70,33 @@ nextPort = unsafePerformIO $ I.newIORef 5000
6870getPort :: IO Int
6971getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
7072
73+withApp :: Settings -> Application -> (Int -> IO a) -> IO a
74+withApp settings app f = do
75+ port <- getPort
76+ baton <- newEmptyMVar
77+ bracket
78+ (forkIO $ runSettings settings
79+ { settingsPort = port
80+ , settingsBeforeMainLoop = putMVar baton ()
81+ } app)
82+ killThread
83+ (const $ takeMVar baton >> f port)
84+
7185runTest :: Int -- ^ expected number of requests
7286 -> CounterApplication
7387 -> [ByteString] -- ^ chunks to send
7488 -> IO ()
7589runTest expected app chunks = do
76− port <- getPort
7790 ref <- I.newIORef (Right 0)
78− tid <- forkIO $ run port $ app ref
79− threadDelay 1000
80− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
81− forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
82− _ <- hGetSome handle 4096
83− threadDelay 1000
84− killThread tid
85− res <- I.readIORef ref
86− case res of
87− Left s -> error s
88− Right i -> i `shouldBe` expected
91+ withApp defaultSettings (app ref) $ \port -> do
92+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
93+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
94+ _ <- hGetSome handle 4096
95+ threadDelay 1000
96+ res <- I.readIORef ref
97+ case res of
98+ Left s -> error s
99+ Right i -> i `shouldBe` expected
89100
90101dummyApp :: Application
91102dummyApp _ = return $ responseLBS status200 [] "foo"
@@ -94,21 +105,17 @@ runTerminateTest :: InvalidRequest
94105 -> ByteString
95106 -> IO ()
96107runTerminateTest expected input = do
97− port <- getPort
98108 ref <- I.newIORef Nothing
99− tid <- forkIO $ runSettings defaultSettings
100− { settingsOnException = \e -> I.writeIORef ref $ Just e
101− , settingsPort = port
102− } dummyApp
103− threadDelay 1000
104− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
105− hPutStr handle input
106− hFlush handle
107− hClose handle
108− threadDelay 1000
109− killThread tid
110− res <- I.readIORef ref
111− show res `shouldBe` show (Just expected)
109+ withApp defaultSettings
110+ { settingsOnException = \e -> I.writeIORef ref $ Just e
111+ } dummyApp $ \port -> do
112+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
113+ hPutStr handle input
114+ hFlush handle
115+ hClose handle
116+ threadDelay 1000
117+ res <- I.readIORef ref
118+ show res `shouldBe` show (Just expected)
112119
113120singleGet :: ByteString
114121singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
@@ -151,149 +158,135 @@ spec = do
151158 describe "special input" $ do
152159 it "multiline headers" $ do
153160 iheaders <- I.newIORef []
154− port <- getPort
155− tid <- forkIO $ run port $ \req -> do
156− liftIO $ I.writeIORef iheaders $ requestHeaders req
157− return $ responseLBS status200 [] ""
158− threadDelay 1000
159− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
160− let input = S.concat
161− [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
161+ let app req = do
162+ liftIO $ I.writeIORef iheaders $ requestHeaders req
163+ return $ responseLBS status200 [] ""
164+ withApp defaultSettings app $ \port -> do
165+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
166+ let input = S.concat
167+ [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
168+ ]
169+ hPutStr handle input
170+ hFlush handle
171+ hClose handle
172+ threadDelay 1000
173+ headers <- I.readIORef iheaders
174+ headers `shouldBe`
175+ [ ("foo", "bar baz\tbin")
162176 ]
163− hPutStr handle input
164− hFlush handle
165− hClose handle
166− threadDelay 1000
167− killThread tid
168− headers <- I.readIORef iheaders
169− headers `shouldBe`
170− [ ("foo", "bar baz\tbin")
171− ]
172177 it "no space between colon and value" $ do
173178 iheaders <- I.newIORef []
174− port <- getPort
175− tid <- forkIO $ run port $ \req -> do
176− liftIO $ I.writeIORef iheaders $ requestHeaders req
177− return $ responseLBS status200 [] ""
178− threadDelay 1000
179− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
180− let input = S.concat
181− [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
179+ let app req = do
180+ liftIO $ I.writeIORef iheaders $ requestHeaders req
181+ return $ responseLBS status200 [] ""
182+ withApp defaultSettings app $ \port -> do
183+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
184+ let input = S.concat
185+ [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
186+ ]
187+ hPutStr handle input
188+ hFlush handle
189+ hClose handle
190+ threadDelay 1000
191+ headers <- I.readIORef iheaders
192+ headers `shouldBe`
193+ [ ("foo", "bar")
182194 ]
183− hPutStr handle input
184− hFlush handle
185− hClose handle
186− threadDelay 1000
187− killThread tid
188− headers <- I.readIORef iheaders
189− headers `shouldBe`
190− [ ("foo", "bar")
191− ]
192195 it "extra spaces in first line" $ do
193196 iheaders <- I.newIORef []
194− port <- getPort
195− tid <- forkIO $ run port $ \req -> do
196− liftIO $ I.writeIORef iheaders $ requestHeaders req
197− return $ responseLBS status200 [] ""
198− threadDelay 1000
199− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
200− let input = S.concat
201− [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"
197+ let app req = do
198+ liftIO $ I.writeIORef iheaders $ requestHeaders req
199+ return $ responseLBS status200 [] ""
200+ withApp defaultSettings app $ \port -> do
201+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
202+ let input = S.concat
203+ [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"
204+ ]
205+ hPutStr handle input
206+ hFlush handle
207+ hClose handle
208+ threadDelay 1000
209+ headers <- I.readIORef iheaders
210+ headers `shouldBe`
211+ [ ("foo", "bar")
202212 ]
203− hPutStr handle input
204− hFlush handle
205− hClose handle
206− threadDelay 1000
207− killThread tid
208− headers <- I.readIORef iheaders
209− headers `shouldBe`
210− [ ("foo", "bar")
211− ]
212213 it "spaces in http version" $ do
213214 iversion <- I.newIORef $ error "Version not parsed"
214− port <- getPort
215− tid <- forkIO $ run port $ \req -> do
216− liftIO $ I.writeIORef iversion $ httpVersion req
217− return $ responseLBS status200 [] ""
218− threadDelay 1000
219− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
220− let input = S.concat
221− [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"
222− ]
223− hPutStr handle input
224− hFlush handle
225− hClose handle
226− threadDelay 1000
227− killThread tid
228− version <- I.readIORef iversion
229− version `shouldBe` http11
215+ let app req = do
216+ liftIO $ I.writeIORef iversion $ httpVersion req
217+ return $ responseLBS status200 [] ""
218+ withApp defaultSettings app $ \port -> do
219+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
220+ let input = S.concat
221+ [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"
222+ ]
223+ hPutStr handle input
224+ hFlush handle
225+ hClose handle
226+ threadDelay 1000
227+ version <- I.readIORef iversion
228+ version `shouldBe` http11
230229
231230 describe "chunked bodies" $ do
232231 it "works" $ do
233232 ifront <- I.newIORef id
234− port <- getPort
235− tid <- forkIO $ run port $ \req -> do
236− bss <- requestBody req $$ Data.Conduit.List.consume
237− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
238− return $ responseLBS status200 [] ""
239− threadDelay 1000
240− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
241− let input = S.concat
242− [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
243− , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
244− , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
245− , "b\r\nHello World\r\n0\r\n\r\n"
233+ let app req = do
234+ bss <- requestBody req $$ Data.Conduit.List.consume
235+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
236+ return $ responseLBS status200 [] ""
237+ withApp defaultSettings app $ \port -> do
238+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
239+ let input = S.concat
240+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
241+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
242+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
243+ , "b\r\nHello World\r\n0\r\n\r\n"
244+ ]
245+ hPutStr handle input
246+ hFlush handle
247+ hClose handle
248+ threadDelay 1000
249+ front <- I.readIORef ifront
250+ front [] `shouldBe`
251+ [ "Hello World\nBye"
252+ , "Hello World"
246253 ]
247− hPutStr handle input
248− hFlush handle
249− hClose handle
250− threadDelay 1000
251− killThread tid
252− front <- I.readIORef ifront
253− front [] `shouldBe`
254− [ "Hello World\nBye"
255− , "Hello World"
256− ]
257254 it "lots of chunks" $ do
258255 ifront <- I.newIORef id
259− port <- getPort
260− tid <- forkIO $ run port $ \req -> do
261− bss <- requestBody req $$ Data.Conduit.List.consume
262− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
263− return $ responseLBS status200 [] ""
264− threadDelay 1000
265− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
266− let input = concat $ replicate 2 $
267− ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
268− (replicate 50 "5\r\n12345\r\n") ++
269− ["0\r\n\r\n"]
270− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
271− hClose handle
272− threadDelay 1000
273− killThread tid
274− front <- I.readIORef ifront
275− front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
256+ let app req = do
257+ bss <- requestBody req $$ Data.Conduit.List.consume
258+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
259+ return $ responseLBS status200 [] ""
260+ withApp defaultSettings app $ \port -> do
261+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
262+ let input = concat $ replicate 2 $
263+ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
264+ (replicate 50 "5\r\n12345\r\n") ++
265+ ["0\r\n\r\n"]
266+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
267+ hClose handle
268+ threadDelay 1000
269+ front <- I.readIORef ifront
270+ front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
276271 it "in chunks" $ do
277272 ifront <- I.newIORef id
278− port <- getPort
279− tid <- forkIO $ run port $ \req -> do
280− bss <- requestBody req $$ Data.Conduit.List.consume
281− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
282− return $ responseLBS status200 [] ""
283− threadDelay 1000
284− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
285− let input = S.concat
286− [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
287− , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
288− , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
289− , "b\r\nHello World\r\n0\r\n\r\n"
273+ let app req = do
274+ bss <- requestBody req $$ Data.Conduit.List.consume
275+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
276+ return $ responseLBS status200 [] ""
277+ withApp defaultSettings app $ \port -> do
278+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
279+ let input = S.concat
280+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
281+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
282+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
283+ , "b\r\nHello World\r\n0\r\n\r\n"
284+ ]
285+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
286+ hClose handle
287+ threadDelay 1000
288+ front <- I.readIORef ifront
289+ front [] `shouldBe`
290+ [ "Hello World\nBye"
291+ , "Hello World"
290292 ]
291− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
292− hClose handle
293− threadDelay 1000
294− killThread tid
295− front <- I.readIORef ifront
296− front [] `shouldBe`
297− [ "Hello World\nBye"
298− , "Hello World"
299− ]