git.iko.soy/typeable/wai
on mime-types-0.1.0.9 help sign in
typeable/wai/warp/test/ExceptionSpec.hs
66 lines 2.3 kB history raw
1{-# LANGUAGE OverloadedStrings, CPP #-}
3module ExceptionSpec (main, spec) where
5#if __GLASGOW_HASKELL__ < 709
6import Control.Applicative
7#endif
8import Control.Monad
9import Network.HTTP.Types hiding (Header)
10import Network.Wai hiding (Response, responseStatus)
11import Network.Wai.Internal (Request(..))
12import Network.Wai.Handler.Warp
13import Test.Hspec
14import Control.Exception
15import qualified Data.Streaming.Network as N
16import Control.Concurrent.Async (withAsync)
17import Network.Socket (close)
19import HTTP
21main :: IO ()
22main = hspec spec
24withTestServer :: (Int -> IO a) -> IO a
25withTestServer inner = bracket
26 (N.bindRandomPortTCP "127.0.0.1")
27 (close . snd)
28 $ \(prt, lsocket) -> do
29 withAsync (runSettingsSocket defaultSettings lsocket testApp)
30 $ \_ -> inner prt
32testApp :: Application
33testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f
34 | x == "statusError" =
35 f $ responseLBS undefined [] "foo"
36 | x == "headersError" =
37 f $ responseLBS ok200 undefined "foo"
38 | x == "headerError" =
39 f $ responseLBS ok200 [undefined] "foo"
40 | x == "bodyError" =
41 f $ responseLBS ok200 [] undefined
42 | x == "ioException" = do
43 void $ fail "ioException"
44 f $ responseLBS ok200 [] "foo"
45testApp _ f =
46 f $ responseLBS ok200 [] "foo"
48spec :: Spec
49spec = describe "responds even if there is an exception" $ do
50 {- Disabling these tests. We can consider forcing evaluation in Warp.
51 it "statusError" $ do
52 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"
53 sc `shouldBe` internalServerError500
54 it "headersError" $ do
55 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"
56 sc `shouldBe` internalServerError500
57 it "headerError" $ do
58 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"
59 sc `shouldBe` internalServerError500
60 it "bodyError" $ do
61 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"
62 sc `shouldBe` internalServerError500
63 -}
64 it "ioException" $ withTestServer $ \prt -> do
65 sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")
66 sc `shouldBe` internalServerError500