git.iko.soy/typeable/wai
on wai-app-static/1.3.0.3 help sign in
typeable/wai/warp/test/RunSpec.hs
299 lines 12 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module RunSpec (main, spec) where
5import Control.Concurrent (forkIO, killThread, threadDelay)
6import Control.Monad (forM_)
7import Control.Monad.IO.Class (MonadIO, liftIO)
8import Data.ByteString (ByteString, hPutStr, hGetSome)
9import qualified Data.ByteString as S
10import qualified Data.ByteString.Lazy as L
11import Data.Conduit (($$))
12import qualified Data.Conduit.List
13import qualified Data.IORef as I
14import Network (connectTo, PortID (PortNumber))
15import Network.HTTP.Types
16import Network.Wai
17import Network.Wai.Handler.Warp
18import System.IO (hFlush, hClose)
19import System.IO.Unsafe (unsafePerformIO)
20import Test.Hspec
22main :: IO ()
23main = hspec spec
25type Counter = I.IORef (Either String Int)
26type CounterApplication = Counter -> Application
28incr :: MonadIO m => Counter -> m ()
29incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
30 ((case ecount of
31 Left s -> Left s
32 Right i -> Right $ i + 1), ())
34err :: (MonadIO m, Show a) => Counter -> a -> m ()
35err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
37readBody :: CounterApplication
38readBody icount req = do
39 body <- requestBody req $$ Data.Conduit.List.consume
40 case () of
41 ()
42 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
43 -> err icount ("Invalid hello" :: String, body)
44 | requestMethod req == "GET" && L.fromChunks body /= ""
45 -> err icount ("Invalid GET" :: String, body)
46 | not $ requestMethod req `elem` ["GET", "POST"]
47 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
48 | otherwise -> incr icount
49 return $ responseLBS status200 [] "Read the body"
51ignoreBody :: CounterApplication
52ignoreBody icount req = do
53 if (requestMethod req `elem` ["GET", "POST"])
54 then incr icount
55 else err icount ("Invalid request method" :: String, requestMethod req)
56 return $ responseLBS status200 [] "Ignored the body"
58doubleConnect :: CounterApplication
59doubleConnect icount req = do
60 _ <- requestBody req $$ Data.Conduit.List.consume
61 _ <- requestBody req $$ Data.Conduit.List.consume
62 incr icount
63 return $ responseLBS status200 [] "double connect"
65nextPort :: I.IORef Int
66nextPort = unsafePerformIO $ I.newIORef 5000
68getPort :: IO Int
69getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
71runTest :: Int -- ^ expected number of requests
72 -> CounterApplication
73 -> [ByteString] -- ^ chunks to send
74 -> IO ()
75runTest expected app chunks = do
76 port <- getPort
77 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
90dummyApp :: Application
91dummyApp _ = return $ responseLBS status200 [] "foo"
93runTerminateTest :: InvalidRequest
94 -> ByteString
95 -> IO ()
96runTerminateTest expected input = do
97 port <- getPort
98 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)
113singleGet :: ByteString
114singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
116singlePostHello :: ByteString
117singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
119spec :: Spec
120spec = do
121 describe "non-pipelining" $ do
122 it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet
123 it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet
124 it "has body, read" $ runTest 2 readBody
125 [ singlePostHello
126 , singleGet
127 ]
128 it "has body, ignore" $ runTest 2 ignoreBody
129 [ singlePostHello
130 , singleGet
131 ]
132 describe "pipelining" $ do
133 it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]
134 it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]
135 it "has body, read" $ runTest 2 readBody $ return $ S.concat
136 [ singlePostHello
137 , singleGet
138 ]
139 it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat
140 [ singlePostHello
141 , singleGet
142 ]
143 describe "no hanging" $ do
144 it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello
145 it "double connect" $ runTest 1 doubleConnect [singlePostHello]
147 describe "connection termination" $ do
148-- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"
149 it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"
151 describe "special input" $ do
152 it "multiline headers" $ do
153 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"
162 ]
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 ]
172 it "no space between colon and value" $ do
173 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"
182 ]
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 ]
192 it "extra spaces in first line" $ do
193 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"
202 ]
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 ]
212 it "spaces in http version" $ do
213 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
231 describe "chunked bodies" $ do
232 it "works" $ do
233 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"
246 ]
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 ]
257 it "lots of chunks" $ do
258 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")
276 it "in chunks" $ do
277 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"
290 ]
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 ]