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