git.iko.soy/typeable/wai
on warp-tls/3.0.1.4 help sign in
typeable/wai/warp/test/ExceptionSpec.hs
79 lines 2.7 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module ExceptionSpec (main, spec) where
5import Control.Applicative
6import Control.Monad
7import Network.HTTP
8import Network.Stream
9import Network.HTTP.Types hiding (Header)
10import Network.Wai hiding (Response)
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 (sClose)
19main :: IO ()
20main = hspec spec
22withTestServer :: (Int -> IO a) -> IO a
23withTestServer inner = bracket
24 (N.bindRandomPortTCP "127.0.0.1")
25 (sClose . snd)
26 $ \(prt, lsocket) -> do
27 withAsync (runSettingsSocket defaultSettings lsocket testApp)
28 $ \_ -> inner prt
30testApp :: Application
31testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f
32 | x == "statusError" =
33 f $ responseLBS undefined [] "foo"
34 | x == "headersError" =
35 f $ responseLBS ok200 undefined "foo"
36 | x == "headerError" =
37 f $ responseLBS ok200 [undefined] "foo"
38 | x == "bodyError" =
39 f $ responseLBS ok200 [] undefined
40 | x == "ioException" = do
41 void $ fail "ioException"
42 f $ responseLBS ok200 [] "foo"
43testApp _ f =
44 f $ responseLBS ok200 [] "foo"
46spec :: Spec
47spec = describe "responds even if there is an exception" $ do
48 {- Disabling these tests. We can consider forcing evaluation in Warp.
49 it "statusError" $ do
50 sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"
51 sc `shouldBe` (5,0,0)
52 it "headersError" $ do
53 sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"
54 sc `shouldBe` (5,0,0)
55 it "headerError" $ do
56 sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"
57 sc `shouldBe` (5,0,0)
58 it "bodyError" $ do
59 sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"
60 sc `shouldBe` (5,0,0)
61 -}
62 it "ioException" $ withTestServer $ \prt -> do
63 sc <- rspCode <$> sendGET (concat $ ["http://127.0.0.1:", show prt, "/ioException"])
64 sc `shouldBe` (5,0,0)
66----------------------------------------------------------------
68sendGET :: String -> IO (Response String)
69sendGET url = sendGETwH url []
71sendGETwH :: String -> [Header] -> IO (Response String)
72sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }
74unResult :: IO (Result (Response String)) -> IO (Response String)
75unResult action = do
76 res <- action
77 case res of
78 Right rsp -> return rsp
79 Left _ -> error "Connection error"