git.iko.soy/typeable/wai
on wai-extra/2.0.1.1 help sign in
typeable/wai/warp/test/RunSpec.hs
295 lines 12 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
4module RunSpec (main, spec, withApp) where
6import Control.Concurrent (forkIO, killThread, threadDelay)
7import Control.Monad (forM_, replicateM_)
8import System.Timeout (timeout)
9import Control.Monad.IO.Class (MonadIO, liftIO)
10import Data.ByteString (ByteString, hPutStr, hGetSome)
11import qualified Data.ByteString as S
12import qualified Data.ByteString.Char8 as S8
13import qualified Data.ByteString.Lazy as L
14import Data.Conduit (($$))
15import qualified Data.Conduit.List
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.Conduit.Network (bindPort)
27import Network.Socket (sClose)
29main :: IO ()
30main = hspec spec
32type Counter = I.IORef (Either String Int)
33type CounterApplication = Counter -> Application
35incr :: MonadIO m => Counter -> m ()
36incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
37 ((case ecount of
38 Left s -> Left s
39 Right i -> Right $ i + 1), ())
41err :: (MonadIO m, Show a) => Counter -> a -> m ()
42err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
44readBody :: CounterApplication
45readBody icount req = do
46 body <- requestBody req $$ Data.Conduit.List.consume
47 case () of
48 ()
49 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
50 -> err icount ("Invalid hello" :: String, body)
51 | requestMethod req == "GET" && L.fromChunks body /= ""
52 -> err icount ("Invalid GET" :: String, body)
53 | not $ requestMethod req `elem` ["GET", "POST"]
54 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
55 | otherwise -> incr icount
56 return $ responseLBS status200 [] "Read the body"
58ignoreBody :: CounterApplication
59ignoreBody icount req = do
60 if (requestMethod req `elem` ["GET", "POST"])
61 then incr icount
62 else err icount ("Invalid request method" :: String, requestMethod req)
63 return $ responseLBS status200 [] "Ignored the body"
65doubleConnect :: CounterApplication
66doubleConnect icount req = do
67 _ <- requestBody req $$ Data.Conduit.List.consume
68 _ <- requestBody req $$ Data.Conduit.List.consume
69 incr icount
70 return $ responseLBS status200 [] "double connect"
72nextPort :: I.IORef Int
73nextPort = unsafePerformIO $ I.newIORef 5000
75getPort :: IO Int
76getPort = do
77 port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
78 esocket <- try $ bindPort port HostIPv4
79 case esocket of
80 Left (_ :: IOException) -> getPort
81 Right socket -> do
82 sClose socket
83 return port
85withApp :: Settings -> Application -> (Int -> IO a) -> IO a
86withApp settings app f = do
87 port <- getPort
88 baton <- newEmptyMVar
89 bracket
90 (forkIO $ runSettings settings
91 { settingsPort = port
92 , settingsBeforeMainLoop = putMVar baton ()
93 } app `onException` putMVar baton ())
94 killThread
95 (const $ takeMVar baton >> f port)
97runTest :: Int -- ^ expected number of requests
98 -> CounterApplication
99 -> [ByteString] -- ^ chunks to send
100 -> IO ()
101runTest expected app chunks = do
102 ref <- I.newIORef (Right 0)
103 withApp defaultSettings (app ref) $ \port -> do
104 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
105 forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
106 _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096
107 res <- I.readIORef ref
108 case res of
109 Left s -> error s
110 Right i -> i `shouldBe` expected
112dummyApp :: Application
113dummyApp _ = return $ responseLBS status200 [] "foo"
115runTerminateTest :: InvalidRequest
116 -> ByteString
117 -> IO ()
118runTerminateTest expected input = do
119 ref <- I.newIORef Nothing
120 withApp defaultSettings
121 { settingsOnException = \_ e -> I.writeIORef ref $ Just e
122 } dummyApp $ \port -> do
123 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
124 hPutStr handle input
125 hFlush handle
126 hClose handle
127 threadDelay 1000
128 res <- I.readIORef ref
129 show res `shouldBe` show (Just expected)
131singleGet :: ByteString
132singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
134singlePostHello :: ByteString
135singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
137spec :: Spec
138spec = do
139 describe "non-pipelining" $ do
140 it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet
141 it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet
142 it "has body, read" $ runTest 2 readBody
143 [ singlePostHello
144 , singleGet
145 ]
146 it "has body, ignore" $ runTest 2 ignoreBody
147 [ singlePostHello
148 , singleGet
149 ]
150 describe "pipelining" $ do
151 it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]
152 it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]
153 it "has body, read" $ runTest 2 readBody $ return $ S.concat
154 [ singlePostHello
155 , singleGet
156 ]
157 it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat
158 [ singlePostHello
159 , singleGet
160 ]
161 describe "no hanging" $ do
162 it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello
163 it "double connect" $ runTest 1 doubleConnect [singlePostHello]
165 describe "connection termination" $ do
166-- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"
167 it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"
169 describe "special input" $ do
170 it "multiline headers" $ do
171 iheaders <- I.newIORef []
172 let app req = do
173 liftIO $ I.writeIORef iheaders $ requestHeaders req
174 return $ responseLBS status200 [] ""
175 withApp defaultSettings app $ \port -> do
176 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
177 let input = S.concat
178 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
179 ]
180 hPutStr handle input
181 hFlush handle
182 hClose handle
183 threadDelay 1000
184 headers <- I.readIORef iheaders
185 headers `shouldBe`
186 [ ("foo", "bar baz\tbin")
187 ]
188 it "no space between colon and value" $ do
189 iheaders <- I.newIORef []
190 let app req = do
191 liftIO $ I.writeIORef iheaders $ requestHeaders req
192 return $ responseLBS status200 [] ""
193 withApp defaultSettings app $ \port -> do
194 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
195 let input = S.concat
196 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
197 ]
198 hPutStr handle input
199 hFlush handle
200 hClose handle
201 threadDelay 1000
202 headers <- I.readIORef iheaders
203 headers `shouldBe`
204 [ ("foo", "bar")
205 ]
207 describe "chunked bodies" $ do
208 it "works" $ do
209 ifront <- I.newIORef id
210 let app req = do
211 bss <- requestBody req $$ Data.Conduit.List.consume
212 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
213 return $ responseLBS status200 [] ""
214 withApp defaultSettings app $ \port -> do
215 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
216 let input = S.concat
217 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
218 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
219 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
220 , "b\r\nHello World\r\n0\r\n\r\n"
221 ]
222 hPutStr handle input
223 hFlush handle
224 hClose handle
225 threadDelay 1000
226 front <- I.readIORef ifront
227 front [] `shouldBe`
228 [ "Hello World\nBye"
229 , "Hello World"
230 ]
231 it "lots of chunks" $ do
232 ifront <- I.newIORef id
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 = concat $ replicate 2 $
240 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
241 (replicate 50 "5\r\n12345\r\n") ++
242 ["0\r\n\r\n"]
243 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
244 hClose handle
245 threadDelay 1000
246 front <- I.readIORef ifront
247 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
248 it "in chunks" $ do
249 ifront <- I.newIORef id
250 let app req = do
251 bss <- requestBody req $$ Data.Conduit.List.consume
252 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
253 return $ responseLBS status200 [] ""
254 withApp defaultSettings app $ \port -> do
255 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
256 let input = S.concat
257 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
258 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
259 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
260 , "b\r\nHello World\r\n0\r\n\r\n"
261 ]
262 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
263 hClose handle
264 threadDelay 1000
265 front <- I.readIORef ifront
266 front [] `shouldBe`
267 [ "Hello World\nBye"
268 , "Hello World"
269 ]
270 it "timeout in request body" $ do
271 ifront <- I.newIORef id
272 let app req = do
273 bss <- (requestBody req $$ Data.Conduit.List.consume) `onException`
274 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))
275 liftIO $ threadDelay 4000000 `onException`
276 I.atomicModifyIORef ifront (\front -> (front . ("threadDelay interrupted":), ()))
277 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
278 return $ responseLBS status200 [] ""
279 withApp defaultSettings { settingsTimeout = 1 } app $ \port -> do
280 let bs1 = S.replicate 2048 88
281 bs2 = "This is short"
282 bs = S.append bs1 bs2
283 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
284 hPutStr handle "POST / HTTP/1.1\r\n"
285 hPutStr handle "content-length: "
286 hPutStr handle $ S8.pack $ show $ S.length bs
287 hPutStr handle "\r\n\r\n"
288 threadDelay 100000
289 hPutStr handle bs1
290 threadDelay 100000
291 hPutStr handle bs2
292 hClose handle
293 threadDelay 5000000
294 front <- I.readIORef ifront
295 S.concat (front []) `shouldBe` bs