@@ -0,0 +1,71 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module ExceptionSpec (main, spec) where
4+
5+import Control.Applicative
6+import Control.Monad
7+import Control.Concurrent (forkIO, threadDelay)
8+import Network.HTTP
9+import Network.Stream
10+import Network.HTTP.Types hiding (Header)
11+import Network.Wai hiding (Response)
12+import Network.Wai.Handler.Warp
13+import System.IO.Unsafe (unsafePerformIO)
14+import Test.Hspec
15+
16+main :: IO ()
17+main = hspec spec
18+
19+testServer :: IO ()
20+testServer =
21+ run 2345 testApp
22+
23+testApp :: Application
24+testApp (Network.Wai.Request {pathInfo = [x]})
25+ | x == "statusError" =
26+ return $ responseLBS undefined [] "foo"
27+ | x == "headersError" =
28+ return $ responseLBS ok200 undefined "foo"
29+ | x == "headerError" =
30+ return $ responseLBS ok200 [undefined] "foo"
31+ | x == "bodyError" =
32+ return $ responseLBS ok200 [] undefined
33+ | x == "ioException" = do
34+ void $ fail "ioException"
35+ return $ responseLBS ok200 [] "foo"
36+testApp _ =
37+ return $ responseLBS ok200 [] "foo"
38+
39+spec :: Spec
40+spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $
41+ describe "responds even if there is an exception" $ do
42+ it "statusError" $ do
43+ sc <- rspCode <$> sendGET "http://localhost:2345/statusError"
44+ sc `shouldBe` (5,0,0)
45+ it "headersError" $ do
46+ sc <- rspCode <$> sendGET "http://localhost:2345/headersError"
47+ sc `shouldBe` (5,0,0)
48+ it "headerError" $ do
49+ sc <- rspCode <$> sendGET "http://localhost:2345/headerError"
50+ sc `shouldBe` (5,0,0)
51+ it "bodyError" $ do
52+ sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"
53+ sc `shouldBe` (5,0,0)
54+ it "ioException" $ do
55+ sc <- rspCode <$> sendGET "http://localhost:2345/ioException"
56+ sc `shouldBe` (5,0,0)
57+
58+----------------------------------------------------------------
59+
60+sendGET :: String -> IO (Response String)
61+sendGET url = sendGETwH url []
62+
63+sendGETwH :: String -> [Header] -> IO (Response String)
64+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }
65+
66+unResult :: IO (Result (Response String)) -> IO (Response String)
67+unResult action = do
68+ res <- action
69+ case res of
70+ Right rsp -> return rsp
71+ Left _ -> error "Connection error"