@@ -4,10 +4,12 @@ import Network.Wai.Handler.Warp
44import qualified Data.IORef as I
55import Control.Monad.IO.Class (MonadIO, liftIO)
66import Network.HTTP.Types
7−import Control.Concurrent (forkIO, killThread)
7+import Control.Concurrent (forkIO, killThread, threadDelay)
8+import Control.Monad (forM_)
89
9−import System.IO (hFlush, hPutStrLn, stderr)
10−import Data.ByteString (hPutStr, hGetSome)
10+import System.IO (hFlush)
11+import Data.ByteString (ByteString, hPutStr, hGetSome)
12+import qualified Data.ByteString as S
1113import qualified Data.ByteString.Lazy as L
1214import Network (connectTo, PortID (PortNumber))
1315
@@ -18,97 +20,85 @@ import Test.HUnit
1820import Data.Conduit (($$))
1921import qualified Data.Conduit.List
2022
21−print' :: (Show a, MonadIO m) => a -> m ()
22−print' = liftIO . hPutStrLn stderr . show
23+type Counter = I.IORef (Either String Int)
24+type CounterApplication = Counter -> Application
2325
24−readBody :: I.IORef Int -> Application
26+incr :: MonadIO m => Counter -> m ()
27+incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
28+ ((case ecount of
29+ Left s -> Left s
30+ Right i -> Right $ i + 1), ())
31+
32+err :: (MonadIO m, Show a) => Counter -> a -> m ()
33+err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
34+
35+readBody :: CounterApplication
2536readBody icount req = do
2637 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, ())
38+ case () of
39+ ()
40+ | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
41+ -> err icount ("Invalid hello" :: String, body)
42+ | requestMethod req == "GET" && L.fromChunks body /= ""
43+ -> err icount ("Invalid GET" :: String, body)
44+ | not $ requestMethod req `elem` ["GET", "POST"]
45+ -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)
46+ | otherwise -> incr icount
3047 return $ responseLBS status200 [] "Read the body"
3148
32−ignoreBody :: I.IORef Int -> Application
49+ignoreBody :: CounterApplication
3350ignoreBody icount req = do
3451 if (requestMethod req `elem` ["GET", "POST"])
35− then liftIO $ I.atomicModifyIORef icount $ \count -> (count + 1, ())
36− else print' ("Invalid request method", requestMethod req)
52+ then incr icount
53+ else err icount ("Invalid request method" :: String, requestMethod req)
3754 return $ responseLBS status200 [] "Ignored the body"
3855
56+runTest :: Int -- ^ expected number of requests
57+ -> Int -- ^ port to run on
58+ -> CounterApplication
59+ -> [ByteString] -- ^ chunks to send
60+ -> IO ()
61+runTest expected port app chunks = do
62+ ref <- I.newIORef (Right 0)
63+ tid <- forkIO $ run port $ app ref
64+ threadDelay 1000
65+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
66+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
67+ _ <- hGetSome handle 4096
68+ threadDelay 1000
69+ killThread tid
70+ res <- I.readIORef ref
71+ case res of
72+ Left s -> error s
73+ Right i -> i @?= expected
74+
75+singleGet :: ByteString
76+singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
77+
78+singlePostHello :: ByteString
79+singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"
80+
3981main :: IO ()
4082main = hspecX $ do
4183 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
84+ it "no body, read" $ runTest 5 5007 readBody $ replicate 5 singleGet
85+ it "no body, ignore" $ runTest 5 5003 ignoreBody $ replicate 5 singleGet
86+ it "has body, read" $ runTest 2 5004 readBody
87+ [ singlePostHello
88+ , singleGet
89+ ]
90+ it "has body, ignore" $ runTest 2 5005 ignoreBody
91+ [ singlePostHello
92+ , singleGet
93+ ]
8194 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
95+ it "no body, read" $ runTest 5 5006 readBody [S.concat $ replicate 5 singleGet]
96+ it "no body, ignore" $ runTest 5 5002 ignoreBody [S.concat $ replicate 5 singleGet]
97+ it "has body, read" $ runTest 2 5001 readBody $ return $ S.concat
98+ [ singlePostHello
99+ , singleGet
100+ ]
101+ it "has body, ignore" $ runTest 2 5000 ignoreBody $ return $ S.concat
102+ [ singlePostHello
103+ , singleGet
104+ ]