git.iko.soy/typeable/wai
on wai-app-static/1.3.3.1 help sign in
typeable/wai/warp/test/RunSpec.hs
329 lines 14 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_)
8import Control.Monad.IO.Class (MonadIO, liftIO)
9import Data.ByteString (ByteString, hPutStr, hGetSome)
10import qualified Data.ByteString as S
11import qualified Data.ByteString.Char8 as S8
12import qualified Data.ByteString.Lazy as L
13import Data.Conduit (($$))
14import qualified Data.Conduit.List
15import qualified Data.IORef as I
16import Network (connectTo, PortID (PortNumber))
17import Network.HTTP.Types
18import Network.Wai
19import Network.Wai.Handler.Warp
20import System.IO (hFlush, hClose)
21import System.IO.Unsafe (unsafePerformIO)
22import Test.Hspec
23import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
24import Control.Exception.Lifted (bracket, try, IOException, onException)
25import Data.Conduit.Network (bindPort)
26import Network.Socket (sClose)
28main :: IO ()
29main = hspec spec
31type Counter = I.IORef (Either String Int)
32type CounterApplication = Counter -> Application
34incr :: MonadIO m => Counter -> m ()
35incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
36 ((case ecount of
37 Left s -> Left s
38 Right i -> Right $ i + 1), ())
40err :: (MonadIO m, Show a) => Counter -> a -> m ()
41err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
43readBody :: CounterApplication
44readBody icount req = do
45 body <- requestBody req $$ Data.Conduit.List.consume
46 case () of
47 ()
48 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
49 -> err icount ("Invalid hello" :: String, body)
50 | requestMethod req == "GET" && L.fromChunks body /= ""
51 -> err icount ("Invalid GET" :: String, body)
52 | not $ requestMethod req `elem` ["GET", "POST"]
53 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
54 | otherwise -> incr icount
55 return $ responseLBS status200 [] "Read the body"
57ignoreBody :: CounterApplication
58ignoreBody icount req = do
59 if (requestMethod req `elem` ["GET", "POST"])
60 then incr icount
61 else err icount ("Invalid request method" :: String, requestMethod req)
62 return $ responseLBS status200 [] "Ignored the body"
64doubleConnect :: CounterApplication
65doubleConnect icount req = do
66 _ <- requestBody req $$ Data.Conduit.List.consume
67 _ <- requestBody req $$ Data.Conduit.List.consume
68 incr icount
69 return $ responseLBS status200 [] "double connect"
71nextPort :: I.IORef Int
72nextPort = unsafePerformIO $ I.newIORef 5000
74getPort :: IO Int
75getPort = do
76 port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
77 esocket <- try $ bindPort port HostIPv4
78 case esocket of
79 Left (_ :: IOException) -> getPort
80 Right socket -> do
81 sClose socket
82 return port
84withApp :: Settings -> Application -> (Int -> IO a) -> IO a
85withApp settings app f = do
86 port <- getPort
87 baton <- newEmptyMVar
88 bracket
89 (forkIO $ runSettings settings
90 { settingsPort = port
91 , settingsBeforeMainLoop = putMVar baton ()
92 } app `onException` putMVar baton ())
93 killThread
94 (const $ takeMVar baton >> f port)
96runTest :: Int -- ^ expected number of requests
97 -> CounterApplication
98 -> [ByteString] -- ^ chunks to send
99 -> IO ()
100runTest expected app chunks = do
101 ref <- I.newIORef (Right 0)
102 withApp defaultSettings (app ref) $ \port -> do
103 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
104 forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
105 _ <- hGetSome handle 4096
106 threadDelay 1000
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 ]
206 it "extra spaces in first line" $ do
207 iheaders <- I.newIORef []
208 let app req = do
209 liftIO $ I.writeIORef iheaders $ requestHeaders req
210 return $ responseLBS status200 [] ""
211 withApp defaultSettings app $ \port -> do
212 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
213 let input = S.concat
214 [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"
215 ]
216 hPutStr handle input
217 hFlush handle
218 hClose handle
219 threadDelay 1000
220 headers <- I.readIORef iheaders
221 headers `shouldBe`
222 [ ("foo", "bar")
223 ]
224 it "spaces in http version" $ do
225 iversion <- I.newIORef $ error "Version not parsed"
226 let app req = do
227 liftIO $ I.writeIORef iversion $ httpVersion req
228 return $ responseLBS status200 [] ""
229 withApp defaultSettings app $ \port -> do
230 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
231 let input = S.concat
232 [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"
233 ]
234 hPutStr handle input
235 hFlush handle
236 hClose handle
237 threadDelay 1000
238 version <- I.readIORef iversion
239 version `shouldBe` http11
241 describe "chunked bodies" $ do
242 it "works" $ do
243 ifront <- I.newIORef id
244 let app req = do
245 bss <- requestBody req $$ Data.Conduit.List.consume
246 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
247 return $ responseLBS status200 [] ""
248 withApp defaultSettings app $ \port -> do
249 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
250 let input = S.concat
251 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
252 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
253 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
254 , "b\r\nHello World\r\n0\r\n\r\n"
255 ]
256 hPutStr handle input
257 hFlush handle
258 hClose handle
259 threadDelay 1000
260 front <- I.readIORef ifront
261 front [] `shouldBe`
262 [ "Hello World\nBye"
263 , "Hello World"
264 ]
265 it "lots of chunks" $ do
266 ifront <- I.newIORef id
267 let app req = do
268 bss <- requestBody req $$ Data.Conduit.List.consume
269 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
270 return $ responseLBS status200 [] ""
271 withApp defaultSettings app $ \port -> do
272 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
273 let input = concat $ replicate 2 $
274 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
275 (replicate 50 "5\r\n12345\r\n") ++
276 ["0\r\n\r\n"]
277 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
278 hClose handle
279 threadDelay 1000
280 front <- I.readIORef ifront
281 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
282 it "in chunks" $ do
283 ifront <- I.newIORef id
284 let app req = do
285 bss <- requestBody req $$ Data.Conduit.List.consume
286 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
287 return $ responseLBS status200 [] ""
288 withApp defaultSettings app $ \port -> do
289 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
290 let input = S.concat
291 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
292 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
293 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
294 , "b\r\nHello World\r\n0\r\n\r\n"
295 ]
296 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
297 hClose handle
298 threadDelay 1000
299 front <- I.readIORef ifront
300 front [] `shouldBe`
301 [ "Hello World\nBye"
302 , "Hello World"
303 ]
304 it "timeout in request body" $ do
305 ifront <- I.newIORef id
306 let app req = do
307 bss <- (requestBody req $$ Data.Conduit.List.consume) `onException`
308 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))
309 liftIO $ threadDelay 4000000 `onException`
310 I.atomicModifyIORef ifront (\front -> (front . ("threadDelay interrupted":), ()))
311 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
312 return $ responseLBS status200 [] ""
313 withApp defaultSettings { settingsTimeout = 1 } app $ \port -> do
314 let bs1 = S.replicate 2048 88
315 bs2 = "This is short"
316 bs = S.append bs1 bs2
317 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
318 hPutStr handle "POST / HTTP/1.1\r\n"
319 hPutStr handle "content-length: "
320 hPutStr handle $ S8.pack $ show $ S.length bs
321 hPutStr handle "\r\n\r\n"
322 threadDelay 100000
323 hPutStr handle bs1
324 threadDelay 100000
325 hPutStr handle bs2
326 hClose handle
327 threadDelay 5000000
328 front <- I.readIORef ifront
329 S.concat (front []) `shouldBe` bs