git.iko.soy/typeable/wai
on wai-app-static/2.0.0.5 help sign in
typeable/wai/warp/test/RunSpec.hs
324 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_, 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)
28import qualified Network.HTTP as HTTP
30main :: IO ()
31main = hspec spec
33type Counter = I.IORef (Either String Int)
34type CounterApplication = Counter -> Application
36incr :: MonadIO m => Counter -> m ()
37incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
38 ((case ecount of
39 Left s -> Left s
40 Right i -> Right $ i + 1), ())
42err :: (MonadIO m, Show a) => Counter -> a -> m ()
43err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
45readBody :: CounterApplication
46readBody icount req = do
47 body <- requestBody req $$ Data.Conduit.List.consume
48 case () of
49 ()
50 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
51 -> err icount ("Invalid hello" :: String, body)
52 | requestMethod req == "GET" && L.fromChunks body /= ""
53 -> err icount ("Invalid GET" :: String, body)
54 | not $ requestMethod req `elem` ["GET", "POST"]
55 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
56 | otherwise -> incr icount
57 return $ responseLBS status200 [] "Read the body"
59ignoreBody :: CounterApplication
60ignoreBody icount req = do
61 if (requestMethod req `elem` ["GET", "POST"])
62 then incr icount
63 else err icount ("Invalid request method" :: String, requestMethod req)
64 return $ responseLBS status200 [] "Ignored the body"
66doubleConnect :: CounterApplication
67doubleConnect icount req = do
68 _ <- requestBody req $$ Data.Conduit.List.consume
69 _ <- requestBody req $$ Data.Conduit.List.consume
70 incr icount
71 return $ responseLBS status200 [] "double connect"
73nextPort :: I.IORef Int
74nextPort = unsafePerformIO $ I.newIORef 5000
76getPort :: IO Int
77getPort = do
78 port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
79 esocket <- try $ bindPort port HostIPv4
80 case esocket of
81 Left (_ :: IOException) -> RunSpec.getPort
82 Right socket -> do
83 sClose socket
84 return port
86withApp :: Settings -> Application -> (Int -> IO a) -> IO a
87withApp settings app f = do
88 port <- RunSpec.getPort
89 baton <- newEmptyMVar
90 let settings' = setPort port
91 $ setBeforeMainLoop (putMVar baton ())
92 settings
93 bracket
94 (forkIO $ runSettings settings' app `onException` putMVar baton ())
95 killThread
96 (const $ takeMVar baton >> f port)
98runTest :: Int -- ^ expected number of requests
99 -> CounterApplication
100 -> [ByteString] -- ^ chunks to send
101 -> IO ()
102runTest expected app chunks = do
103 ref <- I.newIORef (Right 0)
104 withApp defaultSettings (app ref) $ \port -> do
105 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
106 forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
107 _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096
108 res <- I.readIORef ref
109 case res of
110 Left s -> error s
111 Right i -> i `shouldBe` expected
113dummyApp :: Application
114dummyApp _ = return $ responseLBS status200 [] "foo"
116runTerminateTest :: InvalidRequest
117 -> ByteString
118 -> IO ()
119runTerminateTest expected input = do
120 ref <- I.newIORef Nothing
121 let onExc _ = I.writeIORef ref . Just
122 withApp (setOnException onExc defaultSettings) 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 (setTimeout 1 defaultSettings) 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
296 describe "raw body" $ do
297 it "works" $ do
298 let app _req = do
299 let backup = responseLBS status200 [] "Not raw"
300 return $ flip responseRaw backup $ \src sink ->
301 src
302 $$ Data.Conduit.List.map doubleBS
303 =$ sink
304 doubleBS = S.concatMap $ \w -> S.pack [w, w]
305 withApp defaultSettings app $ \port -> do
306 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
307 hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"
308 hFlush handle
309 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")
310 hPutStr handle "67890"
311 hFlush handle
312 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")
314 it "only one date and server header" $ do
315 let app _ = return $ responseLBS status200
316 [ ("server", "server")
317 , ("date", "date")
318 ] ""
319 withApp defaultSettings app $ \port -> do
320 Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)
321 map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrServer res)
322 `shouldBe` ["server"]
323 map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrDate res)
324 `shouldBe` ["date"]