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