git.iko.soy/typeable/wai
on wai-extra/2.1.1.3 help sign in
typeable/wai/warp/test/ExceptionSpec.hs
81 lines 2.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module ExceptionSpec (main, spec) where
5import Control.Applicative
6import Control.Monad
7import Control.Concurrent (forkIO, threadDelay)
8import Network.HTTP
9import Network.Stream
10import Network.HTTP.Types hiding (Header)
11import Network.Wai hiding (Response)
12import Network.Wai.Internal (Request(..))
13import Network.Wai.Handler.Warp
14import System.IO.Unsafe (unsafePerformIO)
15import Test.Hspec
16import Control.Exception
17import qualified Data.Streaming.Network as N
18import Control.Concurrent.Async (withAsync)
19import Network.Socket (sClose)
21main :: IO ()
22main = hspec spec
24withTestServer :: (Int -> IO a) -> IO a
25withTestServer inner = bracket
26 (N.bindRandomPortTCP "*4")
27 (sClose . snd)
28 $ \(port, lsocket) -> do
29 withAsync (runSettingsSocket defaultSettings lsocket testApp)
30 $ \_ -> inner port
32testApp :: Application
33testApp (Network.Wai.Internal.Request {pathInfo = [x]})
34 | x == "statusError" =
35 return $ responseLBS undefined [] "foo"
36 | x == "headersError" =
37 return $ responseLBS ok200 undefined "foo"
38 | x == "headerError" =
39 return $ responseLBS ok200 [undefined] "foo"
40 | x == "bodyError" =
41 return $ responseLBS ok200 [] undefined
42 | x == "ioException" = do
43 void $ fail "ioException"
44 return $ responseLBS ok200 [] "foo"
45testApp _ =
46 return $ 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 <- rspCode <$> sendGET "http://localhost:2345/statusError"
53 sc `shouldBe` (5,0,0)
54 it "headersError" $ do
55 sc <- rspCode <$> sendGET "http://localhost:2345/headersError"
56 sc `shouldBe` (5,0,0)
57 it "headerError" $ do
58 sc <- rspCode <$> sendGET "http://localhost:2345/headerError"
59 sc `shouldBe` (5,0,0)
60 it "bodyError" $ do
61 sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"
62 sc `shouldBe` (5,0,0)
63 -}
64 it "ioException" $ withTestServer $ \port -> do
65 sc <- rspCode <$> sendGET (concat $ ["http://localhost:", show port, "/ioException"])
66 sc `shouldBe` (5,0,0)
68----------------------------------------------------------------
70sendGET :: String -> IO (Response String)
71sendGET url = sendGETwH url []
73sendGETwH :: String -> [Header] -> IO (Response String)
74sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }
76unResult :: IO (Result (Response String)) -> IO (Response String)
77unResult action = do
78 res <- action
79 case res of
80 Right rsp -> return rsp
81 Left _ -> error "Connection error"