git.iko.soy/typeable/wai
on wai-extra/3.0.4.5 help sign in
typeable/wai/warp/test/RunSpec.hs
389 lines 16 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
5module RunSpec (main, spec, withApp) where
7import Control.Concurrent (forkIO, killThread, threadDelay)
8import Control.Monad (forM_, replicateM_, unless)
9import System.Timeout (timeout)
10import Control.Monad.IO.Class (MonadIO, liftIO)
11import Data.ByteString (ByteString, hPutStr, hGetSome)
12import qualified Control.Exception as E
13import qualified Data.ByteString as S
14import qualified Data.ByteString.Char8 as S8
15import qualified Data.ByteString.Lazy as L
16import qualified Data.IORef as I
17import Network (connectTo, PortID (PortNumber))
18import Network.HTTP.Types
19import Network.Wai
20import Network.Wai.Handler.Warp
21import System.IO (hFlush, hClose)
22import System.IO.Unsafe (unsafePerformIO)
23import Test.Hspec
24import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
25import Control.Exception.Lifted (bracket, try, IOException, onException)
26import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)
27import Network.Socket (sClose)
28import qualified Network.HTTP as HTTP
29import Blaze.ByteString.Builder (fromByteString)
30import Network.Socket.ByteString (sendAll)
32main :: IO ()
33main = hspec spec
35type Counter = I.IORef (Either String Int)
36type CounterApplication = Counter -> Application
38incr :: MonadIO m => Counter -> m ()
39incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
40 ((case ecount of
41 Left s -> Left s
42 Right i -> Right $ i + 1), ())
44err :: (MonadIO m, Show a) => Counter -> a -> m ()
45err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
47readBody :: CounterApplication
48readBody icount req f = do
49 body <- consumeBody $ requestBody req
50 case () of
51 ()
52 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
53 -> err icount ("Invalid hello" :: String, body)
54 | requestMethod req == "GET" && L.fromChunks body /= ""
55 -> err icount ("Invalid GET" :: String, body)
56 | not $ requestMethod req `elem` ["GET", "POST"]
57 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
58 | otherwise -> incr icount
59 f $ responseLBS status200 [] "Read the body"
61ignoreBody :: CounterApplication
62ignoreBody icount req f = do
63 if (requestMethod req `elem` ["GET", "POST"])
64 then incr icount
65 else err icount ("Invalid request method" :: String, requestMethod req)
66 f $ responseLBS status200 [] "Ignored the body"
68doubleConnect :: CounterApplication
69doubleConnect icount req f = do
70 _ <- consumeBody $ requestBody req
71 _ <- consumeBody $ requestBody req
72 incr icount
73 f $ responseLBS status200 [] "double connect"
75nextPort :: I.IORef Int
76nextPort = unsafePerformIO $ I.newIORef 5000
77{-# NOINLINE nextPort #-}
79getPort :: IO Int
80getPort = do
81 port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
82 esocket <- try $ bindPortTCP port "127.0.0.1"
83 case esocket of
84 Left (_ :: IOException) -> RunSpec.getPort
85 Right socket -> do
86 sClose socket
87 return port
89withApp :: Settings -> Application -> (Int -> IO a) -> IO a
90withApp settings app f = do
91 port <- RunSpec.getPort
92 baton <- newEmptyMVar
93 let settings' = setPort port
94 $ setHost "127.0.0.1"
95 $ setBeforeMainLoop (putMVar baton ())
96 settings
97 bracket
98 (forkIO $ runSettings settings' app `onException` putMVar baton ())
99 killThread
100 (const $ takeMVar baton >> f port)
102runTest :: Int -- ^ expected number of requests
103 -> CounterApplication
104 -> [ByteString] -- ^ chunks to send
105 -> IO ()
106runTest expected app chunks = do
107 ref <- I.newIORef (Right 0)
108 withApp defaultSettings (app ref) $ \port -> do
109 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
110 forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
111 _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096
112 res <- I.readIORef ref
113 case res of
114 Left s -> error s
115 Right i -> i `shouldBe` expected
117dummyApp :: Application
118dummyApp _ f = f $ responseLBS status200 [] "foo"
120runTerminateTest :: InvalidRequest
121 -> ByteString
122 -> IO ()
123runTerminateTest expected input = do
124 ref <- I.newIORef Nothing
125 let onExc _ = I.writeIORef ref . Just
126 withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do
127 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
128 hPutStr handle input
129 hFlush handle
130 hClose handle
131 threadDelay 1000
132 res <- I.readIORef ref
133 show res `shouldBe` show (Just expected)
135singleGet :: ByteString
136singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
138singlePostHello :: ByteString
139singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
141singleChunkedPostHello :: [ByteString]
142singleChunkedPostHello =
143 [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n"
144 , "5\r\nHello\r\n0\r\n"
145 ]
147spec :: Spec
148spec = do
149 describe "non-pipelining" $ do
150 it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet
151 it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet
152 it "has body, read" $ runTest 2 readBody
153 [ singlePostHello
154 , singleGet
155 ]
156 it "has body, ignore" $ runTest 2 ignoreBody
157 [ singlePostHello
158 , singleGet
159 ]
160 it "chunked body, read" $ runTest 2 readBody $ concat
161 [ singleChunkedPostHello
162 , [singleGet]
163 ]
164 it "chunked body, ignore" $ runTest 2 ignoreBody $ concat
165 [ singleChunkedPostHello
166 , [singleGet]
167 ]
168 describe "pipelining" $ do
169 it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]
170 it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]
171 it "has body, read" $ runTest 2 readBody $ return $ S.concat
172 [ singlePostHello
173 , singleGet
174 ]
175 it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat
176 [ singlePostHello
177 , singleGet
178 ]
179 it "chunked body, read" $ runTest 2 readBody $ return $ S.concat
180 [ S.concat singleChunkedPostHello
181 , singleGet
182 ]
183 it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat
184 [ S.concat singleChunkedPostHello
185 , singleGet
186 ]
187 describe "no hanging" $ do
188 it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello
189 it "double connect" $ runTest 1 doubleConnect [singlePostHello]
191 describe "connection termination" $ do
192-- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"
193 it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"
195 describe "special input" $ do
196 it "multiline headers" $ do
197 iheaders <- I.newIORef []
198 let app req f = do
199 liftIO $ I.writeIORef iheaders $ requestHeaders req
200 f $ responseLBS status200 [] ""
201 withApp defaultSettings app $ \port -> do
202 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
203 let input = S.concat
204 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
205 ]
206 hPutStr handle input
207 hFlush handle
208 hClose handle
209 threadDelay 1000
210 headers <- I.readIORef iheaders
211 headers `shouldBe`
212 [ ("foo", "bar baz\tbin")
213 ]
214 it "no space between colon and value" $ do
215 iheaders <- I.newIORef []
216 let app req f = do
217 liftIO $ I.writeIORef iheaders $ requestHeaders req
218 f $ responseLBS status200 [] ""
219 withApp defaultSettings app $ \port -> do
220 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
221 let input = S.concat
222 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
223 ]
224 hPutStr handle input
225 hFlush handle
226 hClose handle
227 threadDelay 1000
228 headers <- I.readIORef iheaders
229 headers `shouldBe`
230 [ ("foo", "bar")
231 ]
233 describe "chunked bodies" $ do
234 it "works" $ do
235 ifront <- I.newIORef id
236 let app req f = do
237 bss <- consumeBody $ requestBody req
238 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
239 f $ responseLBS status200 [] ""
240 withApp defaultSettings app $ \port -> do
241 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
242 let input = S.concat
243 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
244 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
245 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
246 , "b\r\nHello World\r\n0\r\n\r\n"
247 ]
248 hPutStr handle input
249 hFlush handle
250 hClose handle
251 threadDelay 1000
252 front <- I.readIORef ifront
253 front [] `shouldBe`
254 [ "Hello World\nBye"
255 , "Hello World"
256 ]
257 it "lots of chunks" $ do
258 ifront <- I.newIORef id
259 let app req f = do
260 bss <- consumeBody $ requestBody req
261 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
262 f $ responseLBS status200 [] ""
263 withApp defaultSettings app $ \port -> do
264 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
265 let input = concat $ replicate 2 $
266 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
267 (replicate 50 "5\r\n12345\r\n") ++
268 ["0\r\n\r\n"]
269 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
270 hClose handle
271 threadDelay 100000 -- FIXME why does this delay need to be so high?
272 front <- I.readIORef ifront
273 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
274 it "in chunks" $ do
275 ifront <- I.newIORef id
276 let app req f = do
277 bss <- consumeBody $ requestBody req
278 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
279 f $ responseLBS status200 [] ""
280 withApp defaultSettings app $ \port -> do
281 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
282 let input = S.concat
283 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
284 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
285 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
286 , "b\r\nHello World\r\n0\r\n\r\n"
287 ]
288 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
289 hClose handle
290 threadDelay 1000
291 front <- I.readIORef ifront
292 front [] `shouldBe`
293 [ "Hello World\nBye"
294 , "Hello World"
295 ]
296 it "timeout in request body" $ do
297 ifront <- I.newIORef id
298 let app req f = do
299 bss <- (consumeBody $ requestBody req) `onException`
300 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))
301 liftIO $ threadDelay 4000000 `E.catch` \e -> do
302 I.atomicModifyIORef ifront (\front ->
303 ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e):)
304 , ()))
305 E.throwIO (e :: E.SomeException)
306 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
307 f $ responseLBS status200 [] ""
308 withApp (setTimeout 1 defaultSettings) app $ \port -> do
309 let bs1 = S.replicate 2048 88
310 bs2 = "This is short"
311 bs = S.append bs1 bs2
312 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
313 hPutStr handle "POST / HTTP/1.1\r\n"
314 hPutStr handle "content-length: "
315 hPutStr handle $ S8.pack $ show $ S.length bs
316 hPutStr handle "\r\n\r\n"
317 threadDelay 100000
318 hPutStr handle bs1
319 threadDelay 100000
320 hPutStr handle bs2
321 hClose handle
322 threadDelay 5000000
323 front <- I.readIORef ifront
324 S.concat (front []) `shouldBe` bs
325 describe "raw body" $ do
326 it "works" $ do
327 let app _req f = do
328 let backup = responseLBS status200 [] "Not raw"
329 f $ flip responseRaw backup $ \src sink -> do
330 let loop = do
331 bs <- src
332 unless (S.null bs) $ do
333 sink $ doubleBS bs
334 loop
335 loop
336 doubleBS = S.concatMap $ \w -> S.pack [w, w]
337 withApp defaultSettings app $ \port -> do
338 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
339 hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"
340 hFlush handle
341 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")
342 hPutStr handle "67890"
343 hFlush handle
344 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")
346 it "only one date and server header" $ do
347 let app _ f = f $ responseLBS status200
348 [ ("server", "server")
349 , ("date", "date")
350 ] ""
351 withApp defaultSettings app $ \port -> do
352 Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)
353 map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrServer res)
354 `shouldBe` ["server"]
355 map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrDate res)
356 `shouldBe` ["date"]
358 it "streaming echo #249" $ do
359 let app req f = f $ responseStream status200 [] $ \write _ -> do
360 let loop = do
361 bs <- requestBody req
362 unless (S.null bs) $ do
363 write $ fromByteString bs
364 loop
365 loop
366 withApp defaultSettings app $ \port -> do
367 (socket, _addr) <- getSocketTCP "127.0.0.1" port
368 sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"
369 threadDelay 10000
370 sendAll socket "5\r\nhello\r\n0\r\n\r\n"
371 bs <- safeRecv socket 4096
372 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"
374 it "streaming response with length" $ do
375 let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do
376 replicateM_ 4 $ write $ fromByteString "Hello"
377 withApp defaultSettings app $ \port -> do
378 Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)
379 HTTP.rspBody res `shouldBe` "HelloHelloHelloHello"
381consumeBody :: IO ByteString -> IO [ByteString]
382consumeBody body =
383 loop id
384 where
385 loop front = do
386 bs <- body
387 if S.null bs
388 then return $ front []
389 else loop $ front . (bs:)