@@ -0,0 +1,114 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Network.Wai
3+import Network.Wai.Handler.Warp
4+import qualified Data.IORef as I
5+import Control.Monad.IO.Class (MonadIO, liftIO)
6+import Network.HTTP.Types
7+import Control.Concurrent (forkIO, killThread)
8+
9+import System.IO (hFlush, hPutStrLn, stderr)
10+import Data.ByteString (hPutStr, hGetSome)
11+import qualified Data.ByteString.Lazy as L
12+import Network (connectTo, PortID (PortNumber))
13+
14+import Test.Hspec.Monadic
15+import Test.Hspec.HUnit ()
16+import Test.HUnit
17+
18+import Data.Conduit (($$))
19+import qualified Data.Conduit.List
20+
21+print' :: (Show a, MonadIO m) => a -> m ()
22+print' = liftIO . hPutStrLn stderr . show
23+
24+readBody :: I.IORef Int -> Application
25+readBody icount req = do
26+ body <- requestBody req $$ Data.Conduit.List.consume
27+ if (pathInfo req == ["hello"] && L.fromChunks body /= "Hello")
28+ then print' ("Invalid hello", body)
29+ else liftIO $ I.atomicModifyIORef icount $ \count -> (count + 1, ())
30+ return $ responseLBS status200 [] "Read the body"
31+
32+ignoreBody :: I.IORef Int -> Application
33+ignoreBody icount req = do
34+ if (requestMethod req `elem` ["GET", "POST"])
35+ then liftIO $ I.atomicModifyIORef icount $ \count -> (count + 1, ())
36+ else print' ("Invalid request method", requestMethod req)
37+ return $ responseLBS status200 [] "Ignored the body"
38+
39+main :: IO ()
40+main = hspecX $ do
41+ describe "non-pipelining" $ do
42+ it "no body" $ do
43+ icount <- I.newIORef 0
44+ tid <- forkIO $ run 5003 $ readBody icount
45+ handle <- connectTo "127.0.0.1" $ PortNumber 5003
46+ hPutStr handle "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
47+ hFlush handle
48+ res <- hGetSome handle 4096
49+ hPutStr handle "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
50+ hFlush handle
51+ res <- hGetSome handle 4096
52+ killThread tid
53+ count <- I.readIORef icount
54+ count @?= 2
55+ it "app reads the body" $ do
56+ icount <- I.newIORef 0
57+ tid <- forkIO $ run 5004 $ readBody icount
58+ handle <- connectTo "127.0.0.1" $ PortNumber 5004
59+ hPutStr handle "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
60+ hFlush handle
61+ res <- hGetSome handle 4096
62+ hPutStr handle "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
63+ hFlush handle
64+ res <- hGetSome handle 4096
65+ killThread tid
66+ count <- I.readIORef icount
67+ count @?= 2
68+ it "app ignores the body" $ do
69+ icount <- I.newIORef 0
70+ tid <- forkIO $ run 5005 $ ignoreBody icount
71+ handle <- connectTo "127.0.0.1" $ PortNumber 5005
72+ hPutStr handle "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
73+ hFlush handle
74+ res <- hGetSome handle 4096
75+ hPutStr handle "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
76+ hFlush handle
77+ res <- hGetSome handle 4096
78+ killThread tid
79+ count <- I.readIORef icount
80+ count @?= 2
81+ describe "pipelining" $ do
82+ it "no body" $ do
83+ icount <- I.newIORef 0
84+ tid <- forkIO $ run 5002 $ readBody icount
85+ handle <- connectTo "127.0.0.1" $ PortNumber 5002
86+ hPutStr handle "GET / HTTP/1.1\r\nHost: localhost\r\n\r\nGET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
87+ hFlush handle
88+ res <- hGetSome handle 4096
89+ print res
90+ killThread tid
91+ count <- I.readIORef icount
92+ count @?= 2
93+ it "app reads the body" $ do
94+ icount <- I.newIORef 0
95+ tid <- forkIO $ run 5001 $ readBody icount
96+ handle <- connectTo "127.0.0.1" $ PortNumber 5001
97+ hPutStr handle "POST / HTTP/1.1\r\nHost: localhost\r\nContent-Length: 5\r\n\r\nHello\r\n\r\nGET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
98+ hFlush handle
99+ res <- hGetSome handle 4096
100+ print res
101+ killThread tid
102+ count <- I.readIORef icount
103+ count @?= 2
104+ it "app ignores the body" $ do
105+ icount <- I.newIORef 0
106+ tid <- forkIO $ run 5000 $ ignoreBody icount
107+ handle <- connectTo "127.0.0.1" $ PortNumber 5000
108+ hPutStr handle "POST / HTTP/1.1\r\nHost: localhost\r\nContent-Length: 5\r\n\r\nHello\r\nGET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
109+ hFlush handle
110+ res <- hGetSome handle 4096
111+ print res
112+ killThread tid
113+ count <- I.readIORef icount
114+ count @?= 2